{-# 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.Getter
import Control.Lens.Internal.TH
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Monad
import Data.Char (isUpper)
import qualified Data.List as List
import Data.Set.Lens
import Data.Traversable
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
import Language.Haskell.TH.Lens
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (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
datatypeTypeKinded 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
datatypeTypeKinded 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
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> Type -> Type
quantifyType [] (Set Name -> Stab -> Type
stabToType Set Name
forall a. Set a
Set.empty 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 :: Set Name -> Stab -> Type
stabToType :: Set Name -> Stab -> Type
stabToType Set Name
clsTVBNames stab :: Stab
stab@(Stab [Type]
cx OpticType
ty Type
s Type
t Type
a Type
b) =
Set Name -> [Type] -> Type -> Type
quantifyType' Set Name
clsTVBNames [Type]
cx Type
stabTy
where
stabTy :: Type
stabTy =
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]
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]
List.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 a. (k -> a) -> Set k -> Map k a
Map.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 a. (k -> a) -> Set k -> Map k a
Map.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))
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]
[Type] -> Type -> Type
quantifyType [] (Type -> Type) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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"
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]
[[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 (Name -> NCon -> DecsQ
mkMethod Name
r) [NCon]
cons'
CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([TypeQ] -> CxtQ
cxt[]) Name
className (Name -> TyVarBndr
D.plainTV Name
r TyVarBndr -> [TyVarBndr] -> [TyVarBndr]
forall a. a -> [a] -> [a]
: [TyVarBndr]
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 :: Name -> NCon -> DecsQ
mkMethod Name
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 rTy :: Type
rTy = Name -> Type
VarT Name
r
stab' :: Stab
stab' = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
o Type
rTy Type
rTy 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 (Set Name -> Stab -> Type
stabToType ([Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList (Name
rName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name]
vNames)) 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 :: [TyVarBndr]
vs = [Type] -> [TyVarBndr]
D.freeVariablesWellScoped [Type
t]
vNames :: [Name]
vNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
forall flag. TyVarBndr -> Name
D.tvName [TyVarBndr]
vs
fds :: Name -> [FunDep]
fds Name
r
| [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr]
vs = []
| Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
r] [Name]
vNames]
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 :: [TyVarBndr]
vs = [Type] -> [TyVarBndr]
D.freeVariablesWellScoped [Type
s]
cls :: Type
cls = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (TyVarBndr -> Type) -> [TyVarBndr] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Type
forall flag. TyVarBndr -> Type
tvbToType [TyVarBndr]
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
List.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