{-# LANGUAGE CPP #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
#include "lens-common.h"
module Control.Lens.Internal.PrismTH
( makePrisms
, makeClassyPrisms
, makeDecPrisms
) where
import Control.Applicative
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Internal.TH
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Monad
import Data.Char (isUpper)
import Data.List
import Data.Set.Lens
import Data.Traversable
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import Language.Haskell.TH.Lens
import qualified Data.Map as Map
import qualified Data.Set as Set
import Prelude
makePrisms :: Name -> DecsQ
makePrisms :: Name -> DecsQ
makePrisms = Bool -> Name -> DecsQ
makePrisms' Bool
True
makeClassyPrisms :: Name -> DecsQ
makeClassyPrisms :: Name -> DecsQ
makeClassyPrisms = Bool -> Name -> DecsQ
makePrisms' Bool
False
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' Bool
normal Name
typeName =
do DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
typeName
let cls :: Maybe Name
cls | Bool
normal = Maybe Name
forall a. Maybe a
Nothing
| Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms (DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> NCon
normalizeCon [ConstructorInfo]
cons) Maybe Name
cls
makeDecPrisms :: Bool -> Dec -> DecsQ
makeDecPrisms :: Bool -> Dec -> DecsQ
makeDecPrisms Bool
normal Dec
dec =
do DatatypeInfo
info <- Dec -> Q DatatypeInfo
D.normalizeDec Dec
dec
let cls :: Maybe Name
cls | Bool
normal = Maybe Name
forall a. Maybe a
Nothing
| Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms (DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> NCon
normalizeCon [ConstructorInfo]
cons) Maybe Name
cls
makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms Type
t [con :: NCon
con@(NCon Name
_ [] [] [Type]
_)] Maybe Name
Nothing = Type -> NCon -> DecsQ
makeConIso Type
t NCon
con
makeConsPrisms Type
t [NCon]
cons Maybe Name
Nothing =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [NCon] -> (NCon -> DecsQ) -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NCon]
cons ((NCon -> DecsQ) -> Q [[Dec]]) -> (NCon -> DecsQ) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \NCon
con ->
do let conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
let n :: Name
n = Name -> Name
prismName Name
conName
[Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
( [ Name -> TypeQ -> Q Dec
sigD Name
n (Type -> TypeQ
close (Stab -> Type
stabToType Stab
stab))
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
n) (ExpQ -> BodyQ
normalB (Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con)) []
]
[Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ Name -> [Q Dec]
inlinePragma Name
n
)
makeConsPrisms Type
t [NCon]
cons (Just Name
typeName) =
[Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
t Name
className Name
methodName [NCon]
cons
, Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
t Name
className Name
methodName [NCon]
cons
]
where
typeNameBase :: String
typeNameBase = Name -> String
nameBase Name
typeName
className :: Name
className = String -> Name
mkName (String
"As" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeNameBase)
sameNameAsCon :: Bool
sameNameAsCon = (NCon -> Bool) -> [NCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\NCon
con -> Name -> String
nameBase (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
typeNameBase) [NCon]
cons
methodName :: Name
methodName = Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
typeName
data OpticType = PrismType | ReviewType
data Stab = Stab Cxt OpticType Type Type Type Type
simplifyStab :: Stab -> Stab
simplifyStab :: Stab -> Stab
simplifyStab (Stab [Type]
cx OpticType
ty Type
_ Type
t Type
_ Type
b) = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
ty Type
t Type
t Type
b Type
b
stabSimple :: Stab -> Bool
stabSimple :: Stab -> Bool
stabSimple (Stab [Type]
_ OpticType
_ Type
s Type
t Type
a Type
b) = 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
stabToType :: Stab -> Type
stabToType :: Stab -> Type
stabToType stab :: Stab
stab@(Stab [Type]
cx OpticType
ty Type
s Type
t Type
a Type
b) = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
vs [Type]
cx (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
case OpticType
ty of
OpticType
PrismType | Stab -> Bool
stabSimple Stab
stab -> Name
prism'TypeName Name -> [Type] -> Type
`conAppsT` [Type
t,Type
b]
| Bool
otherwise -> Name
prismTypeName Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
OpticType
ReviewType -> Name
reviewTypeName Name -> [Type] -> Type
`conAppsT` [Type
t,Type
b]
where
vs :: [TyVarBndr]
vs = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV
([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub
([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Getting (Endo [Name]) [Type] Name -> [Type] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Name]) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
cx
stabType :: Stab -> OpticType
stabType :: Stab -> OpticType
stabType (Stab [Type]
_ OpticType
o Type
_ Type
_ Type
_ Type
_) = OpticType
o
computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con =
do let cons' :: [NCon]
cons' = NCon -> [NCon] -> [NCon]
forall a. Eq a => a -> [a] -> [a]
delete NCon
con [NCon]
cons
if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NCon -> [Name]
_nconVars NCon
con)
then Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) [NCon]
cons' NCon
con
else Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
computeReviewType :: Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
s' [Type]
cx [Type]
tys =
do let t :: Type
t = Type
s'
Type
s <- (Name -> Type) -> Q Name -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
newName String
"s")
Type
a <- (Name -> Type) -> Q Name -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
newName String
"a")
Type
b <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
tys)
Stab -> Q Stab
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
ReviewType Type
s Type
t Type
a Type
b)
computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType :: Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t [Type]
cx [NCon]
cons NCon
con =
do let ts :: [Type]
ts = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con
unbound :: Set Name
unbound = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Getting (Set Name) [NCon] Name -> [NCon] -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) [NCon] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [NCon]
cons
Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k v. (k -> v) -> Set k -> Map k v
fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unbound)
Type
b <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ts)
Type
a <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
ts))
let s :: Type
s = Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
t
Stab -> Q Stab
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
PrismType Type
s Type
t Type
a Type
b)
computeIsoType :: Type -> [Type] -> TypeQ
computeIsoType :: Type -> [Type] -> TypeQ
computeIsoType Type
t' [Type]
fields =
do Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k v. (k -> v) -> Set k -> Map k v
fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t'))
let t :: TypeQ
t = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t'
s :: TypeQ
s = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
t')
b :: TypeQ
b = [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
fields)
a :: TypeQ
a = [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
fields))
#ifndef HLINT
ty :: TypeQ
ty | Map Name Name -> Bool
forall k a. Map k a -> Bool
Map.null Map Name Name
sub = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
iso'TypeName) [TypeQ
t,TypeQ
b]
| Bool
otherwise = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
isoTypeName) [TypeQ
s,TypeQ
t,TypeQ
a,TypeQ
b]
#endif
Type -> TypeQ
close (Type -> TypeQ) -> TypeQ -> TypeQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty
makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con =
case Stab -> OpticType
stabType Stab
stab of
OpticType
PrismType -> Stab -> [NCon] -> NCon -> ExpQ
makeConPrismExp Stab
stab [NCon]
cons NCon
con
OpticType
ReviewType -> NCon -> ExpQ
makeConReviewExp NCon
con
makeConIso :: Type -> NCon -> DecsQ
makeConIso :: Type -> NCon -> DecsQ
makeConIso Type
s NCon
con =
do let ty :: TypeQ
ty = Type -> [Type] -> TypeQ
computeIsoType Type
s (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
defName :: Name
defName = Name -> Name
prismName (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con)
[Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
( [ Name -> TypeQ -> Q Dec
sigD Name
defName TypeQ
ty
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB (NCon -> ExpQ
makeConIsoExp NCon
con)) []
] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
Name -> [Q Dec]
inlinePragma Name
defName
)
makeConPrismExp ::
Stab ->
[NCon] ->
NCon ->
ExpQ
makeConPrismExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConPrismExp Stab
stab [NCon]
cons NCon
con = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
prismValName, ExpQ
reviewer, ExpQ
remitter]
where
ts :: [Type]
ts = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con
fields :: Int
fields = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields
remitter :: ExpQ
remitter | Stab -> Bool
stabSimple Stab
stab = Name -> Int -> Int -> ExpQ
makeSimpleRemitter Name
conName ([NCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NCon]
cons) Int
fields
| Bool
otherwise = [NCon] -> Name -> ExpQ
makeFullRemitter [NCon]
cons Name
conName
makeConIsoExp :: NCon -> ExpQ
makeConIsoExp :: NCon -> ExpQ
makeConIsoExp NCon
con = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
isoValName, ExpQ
remitter, ExpQ
reviewer]
where
conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
fields :: Int
fields = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields
remitter :: ExpQ
remitter = Name -> Int -> ExpQ
makeIsoRemitter Name
conName Int
fields
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp NCon
con = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
untoValName) ExpQ
reviewer
where
conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
fields :: Int
fields = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields
makeReviewer :: Name -> Int -> ExpQ
makeReviewer :: Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields =
do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
PatQ -> ExpQ -> ExpQ
lam1E ([PatQ] -> PatQ
toTupleP ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
(Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs)
makeSimpleRemitter ::
Name ->
Int ->
Int ->
ExpQ
makeSimpleRemitter :: Name -> Int -> Int -> ExpQ
makeSimpleRemitter Name
conName Int
numCons Int
fields =
do Name
x <- String -> Q Name
newName String
"x"
[Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" Int
fields
let matches :: [MatchQ]
matches =
[ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
(ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
rightDataName) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))))
[]
] [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
[ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
leftDataName) (Name -> ExpQ
varE Name
x))) []
| Int
numCons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
]
PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
matches)
makeFullRemitter :: [NCon] -> Name -> ExpQ
makeFullRemitter :: [NCon] -> Name -> ExpQ
makeFullRemitter [NCon]
cons Name
target =
do Name
x <- String -> Q Name
newName String
"x"
PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((NCon -> MatchQ) -> [NCon] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map NCon -> MatchQ
mkMatch [NCon]
cons))
where
mkMatch :: NCon -> MatchQ
mkMatch (NCon Name
conName [Name]
_ [Type]
_ [Type]
n) =
do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
n)
PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
(ExpQ -> BodyQ
normalB
(if Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
target
then ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
rightDataName) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))
else ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
leftDataName) (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs)))
[]
makeIsoRemitter :: Name -> Int -> ExpQ
makeIsoRemitter :: Name -> Int -> ExpQ
makeIsoRemitter Name
conName Int
fields =
do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
PatQ -> ExpQ -> ExpQ
lam1E (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))
makeClassyPrismClass ::
Type ->
Name ->
Name ->
[NCon] ->
DecQ
makeClassyPrismClass :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
t Name
className Name
methodName [NCon]
cons =
do Name
r <- String -> Q Name
newName String
"r"
#ifndef HLINT
let methodType :: TypeQ
methodType = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
prism'TypeName) [Name -> TypeQ
varT Name
r,Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t]
#endif
[[Dec]]
methodss <- (NCon -> DecsQ) -> [NCon] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type -> NCon -> DecsQ
mkMethod (Name -> Type
VarT Name
r)) [NCon]
cons'
CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([TypeQ] -> CxtQ
cxt[]) Name
className ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV (Name
r Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
vs)) (Name -> [FunDep]
fds Name
r)
( Name -> TypeQ -> Q Dec
sigD Name
methodName TypeQ
methodType
Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)
)
where
mkMethod :: Type -> NCon -> DecsQ
mkMethod Type
r NCon
con =
do Stab [Type]
cx OpticType
o Type
_ Type
_ Type
_ Type
b <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
let stab' :: Stab
stab' = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
o Type
r Type
r Type
b Type
b
defName :: Name
defName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
body :: ExpQ
body = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
composeValName, Name -> ExpQ
varE Name
methodName, Name -> ExpQ
varE Name
defName]
[Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
[ Name -> TypeQ -> Q Dec
sigD Name
defName (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Stab -> Type
stabToType Stab
stab'))
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
body) []
]
cons' :: [NCon]
cons' = (NCon -> NCon) -> [NCon] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (ASetter NCon NCon Name Name -> (Name -> Name) -> NCon -> NCon
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter NCon NCon Name Name
Lens' NCon Name
nconName Name -> Name
prismName) [NCon]
cons
vs :: [Name]
vs = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t)
fds :: Name -> [FunDep]
fds Name
r
| [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vs = []
| Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
r] [Name]
vs]
makeClassyPrismInstance ::
Type ->
Name ->
Name ->
[NCon] ->
DecQ
makeClassyPrismInstance :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
s Name
className Name
methodName [NCon]
cons =
do let vs :: [Name]
vs = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s)
cls :: Type
cls = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vs)
CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
cls)
( PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
methodName)
(ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
idValName)) []
Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [ do Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
s [NCon]
cons NCon
con
let stab' :: Stab
stab' = Stab -> Stab
simplifyStab Stab
stab
PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (Name -> Name
prismName Name
conName))
(ExpQ -> BodyQ
normalB (Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab' [NCon]
cons NCon
con)) []
| NCon
con <- [NCon]
cons
, let conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
]
)
data NCon = NCon
{ NCon -> Name
_nconName :: Name
, NCon -> [Name]
_nconVars :: [Name]
, NCon -> [Type]
_nconCxt :: Cxt
, NCon -> [Type]
_nconTypes :: [Type]
}
deriving (NCon -> NCon -> Bool
(NCon -> NCon -> Bool) -> (NCon -> NCon -> Bool) -> Eq NCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NCon -> NCon -> Bool
$c/= :: NCon -> NCon -> Bool
== :: NCon -> NCon -> Bool
$c== :: NCon -> NCon -> Bool
Eq)
instance HasTypeVars NCon where
typeVarsEx :: Set Name -> Traversal' NCon Name
typeVarsEx Set Name
s Name -> f Name
f (NCon Name
x [Name]
vars [Type]
y [Type]
z) = Name -> [Name] -> [Type] -> [Type] -> NCon
NCon Name
x [Name]
vars ([Type] -> [Type] -> NCon) -> f [Type] -> f ([Type] -> NCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> [Type] -> f [Type]
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f [Type]
y f ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> [Type] -> f [Type]
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f [Type]
z
where s' :: Set Name
s' = (Set Name -> Name -> Set Name) -> Set Name -> [Name] -> Set Name
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name -> Set Name -> Set Name) -> Set Name -> Name -> Set Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Name
s [Name]
vars
nconName :: Lens' NCon Name
nconName :: (Name -> f Name) -> NCon -> f NCon
nconName Name -> f Name
f NCon
x = (Name -> NCon) -> f Name -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> NCon
x {_nconName :: Name
_nconName = Name
y}) (Name -> f Name
f (NCon -> Name
_nconName NCon
x))
nconCxt :: Lens' NCon Cxt
nconCxt :: ([Type] -> f [Type]) -> NCon -> f NCon
nconCxt [Type] -> f [Type]
f NCon
x = ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconCxt :: [Type]
_nconCxt = [Type]
y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconCxt NCon
x))
nconTypes :: Lens' NCon [Type]
nconTypes :: ([Type] -> f [Type]) -> NCon -> f NCon
nconTypes [Type] -> f [Type]
f NCon
x = ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconTypes :: [Type]
_nconTypes = [Type]
y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconTypes NCon
x))
normalizeCon :: D.ConstructorInfo -> NCon
normalizeCon :: ConstructorInfo -> NCon
normalizeCon ConstructorInfo
info = Name -> [Name] -> [Type] -> [Type] -> NCon
NCon (ConstructorInfo -> Name
D.constructorName ConstructorInfo
info)
(TyVarBndr -> Name
forall flag. TyVarBndr -> Name
D.tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [TyVarBndr]
D.constructorVars ConstructorInfo
info)
(ConstructorInfo -> [Type]
D.constructorContext ConstructorInfo
info)
(ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
info)
prismName :: Name -> Name
prismName :: Name -> Name
prismName = Bool -> Name -> Name
prismName' Bool
False
prismName' ::
Bool ->
Name ->
Name
prismName' :: Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
n =
case Name -> String
nameBase Name
n of
[] -> String -> Name
forall a. HasCallStack => String -> a
error String
"prismName: empty name base?"
nb :: String
nb@(Char
x:String
_) | Char -> Bool
isUpper Char
x -> String -> Name
mkName (Char -> String -> String
prefix Char
'_' String
nb)
| Bool
otherwise -> String -> Name
mkName (Char -> String -> String
prefix Char
'.' String
nb)
where
prefix :: Char -> String -> String
prefix :: Char -> String -> String
prefix Char
char String
str | Bool
sameNameAsCon = Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str
| Bool
otherwise = Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str
close :: Type -> TypeQ
close :: Type -> TypeQ
close Type
t = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV (Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
vs)) ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t)
where
vs :: Set Name
vs = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t