{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Trans.DeriveUntrans (
deriveUntrans
) where
import Control.Lens ( view ,(^.))
import Control.Monad ( liftM )
import Control.Monad.Trans ( lift )
import Data.Comp.Multi ( Alg, cata, (:&:)(..) )
import Language.Haskell.TH
import Data.Comp.Trans.Util
deriveUntrans :: [Name] -> Type -> CompTrans [Dec]
deriveUntrans :: [Name] -> Type -> CompTrans [Dec]
deriveUntrans names :: [Name]
names term :: Type
term = do [Dec]
targDec <- Name -> CompTrans [Dec]
mkTarg Name
targNm
[Dec]
wrapperDec <- Name -> Name -> Name -> CompTrans [Dec]
mkWrapper Name
wrapNm Name
unwrapNm Name
targNm
[Dec]
fnDec <- Name -> Type -> Name -> Name -> Name -> CompTrans [Dec]
mkFn Name
untranslateNm Type
term Name
targNm Name
unwrapNm Name
fnNm
[Dec]
classDec <- Name -> Name -> Name -> CompTrans [Dec]
mkClass Name
classNm Name
fnNm Name
wrapNm
[Dec]
instances <- ([[Dec]] -> [Dec]) -> CompTrans [[Dec]] -> CompTrans [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (CompTrans [[Dec]] -> CompTrans [Dec])
-> CompTrans [[Dec]] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ (Name -> CompTrans [Dec]) -> [Name] -> CompTrans [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance Name
classNm Name
fnNm Name
wrapNm Name
unwrapNm Name
targNm) [Name]
names
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> CompTrans [Dec]) -> [Dec] -> CompTrans [Dec]
forall a b. (a -> b) -> a -> b
$ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Dec]
targDec
, [Dec]
wrapperDec
, [Dec]
fnDec
, [Dec]
classDec
, [Dec]
instances
]
where
targNm :: Name
targNm = String -> Name
mkName "Targ"
wrapNm :: Name
wrapNm = String -> Name
mkName "T"
unwrapNm :: Name
unwrapNm = String -> Name
mkName "t"
untranslateNm :: Name
untranslateNm = String -> Name
mkName "untranslate"
classNm :: Name
classNm = String -> Name
mkName "Untrans"
fnNm :: Name
fnNm = String -> Name
mkName "untrans"
mkTarg :: Name -> CompTrans [Dec]
mkTarg :: Name -> CompTrans [Dec]
mkTarg targNm :: Name
targNm = do Name
i <- ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "i"
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeFamilyHead -> Dec
OpenTypeFamilyD (Name
-> [TyVarBndr]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
targNm [Name -> TyVarBndr
PlainTV Name
i] FamilyResultSig
NoSig Maybe InjectivityAnn
forall a. Maybe a
Nothing)]
mkWrapper :: Name -> Name -> Name -> CompTrans [Dec]
mkWrapper :: Name -> Name -> Name -> CompTrans [Dec]
mkWrapper tpNm :: Name
tpNm fNm :: Name
fNm targNm :: Name
targNm = do Name
i <- ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "i"
let con :: Con
con = Name -> [VarBangType] -> Con
RecC Name
tpNm [(Name
fNm, Bang
bang, Type -> Type -> Type
AppT (Name -> Type
ConT Name
targNm) (Name -> Type
VarT Name
i))]
bang :: Bang
bang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
nt :: Dec
nt = Cxt
-> Name -> [TyVarBndr] -> Maybe Type -> Con -> [DerivClause] -> Dec
NewtypeD [] Name
tpNm [Name -> TyVarBndr
PlainTV Name
i] Maybe Type
forall a. Maybe a
Nothing Con
con []
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
nt]
mkFn :: Name -> Type -> Name -> Name -> Name -> CompTrans [Dec]
mkFn :: Name -> Type -> Name -> Name -> Name -> CompTrans [Dec]
mkFn fnNm :: Name
fnNm term :: Type
term targNm :: Name
targNm fldNm :: Name
fldNm untransNm :: Name
untransNm = [CompTrans Dec] -> CompTrans [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CompTrans Dec
sig, CompTrans Dec
def]
where
sig :: CompTrans Dec
sig = do Name
i <- ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "i"
ReaderT TransCtx Q Dec -> CompTrans Dec
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Dec -> CompTrans Dec)
-> ReaderT TransCtx Q Dec -> CompTrans Dec
forall a b. (a -> b) -> a -> b
$ Q Dec -> ReaderT TransCtx Q Dec
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> ReaderT TransCtx Q Dec)
-> Q Dec -> ReaderT TransCtx Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ -> Q Dec
sigD Name
fnNm ([TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT [Name -> TyVarBndr
PlainTV Name
i] (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return []) (TypeQ -> TypeQ
typ (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
varT Name
i))
typ :: Q Type -> Q Type
typ :: TypeQ -> TypeQ
typ i :: TypeQ
i = [t| $term' $i -> $targ $i |]
term' :: TypeQ
term' = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
term
targ :: TypeQ
targ = Name -> TypeQ
conT Name
targNm
def :: CompTrans Dec
def = ReaderT TransCtx Q Dec -> CompTrans Dec
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Dec -> CompTrans Dec)
-> ReaderT TransCtx Q Dec -> CompTrans Dec
forall a b. (a -> b) -> a -> b
$ Q Dec -> ReaderT TransCtx Q Dec
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> ReaderT TransCtx Q Dec)
-> Q Dec -> ReaderT TransCtx Q Dec
forall a b. (a -> b) -> a -> b
$ PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
fnNm) (ExpQ -> BodyQ
normalB ExpQ
body) []
body :: ExpQ
body = [| $fld . cata $untrans |]
fld :: ExpQ
fld = Name -> ExpQ
varE Name
fldNm
untrans :: ExpQ
untrans = Name -> ExpQ
varE Name
untransNm
mkClass :: Name -> Name -> Name -> CompTrans [Dec]
mkClass :: Name -> Name -> Name -> CompTrans [Dec]
mkClass classNm :: Name
classNm funNm :: Name
funNm newtpNm :: Name
newtpNm = do Name
f <- ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "f"
let funDec :: Dec
funDec = Name -> Type -> Dec
SigD Name
funNm (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT ''Alg) (Name -> Type
VarT Name
f)) (Name -> Type
ConT Name
newtpNm))
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> Dec
ClassD [] Name
classNm [Name -> TyVarBndr
PlainTV Name
f] [] [Dec
funDec]]
mkInstance :: Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance :: Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance classNm :: Name
classNm funNm :: Name
funNm wrap :: Name
wrap unwrap :: Name
unwrap targNm :: Name
targNm typNm :: Name
typNm = do Info
inf <- ReaderT TransCtx Q Info -> CompTrans Info
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Info -> CompTrans Info)
-> ReaderT TransCtx Q Info -> CompTrans Info
forall a b. (a -> b) -> a -> b
$ Q Info -> ReaderT TransCtx Q Info
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Info -> ReaderT TransCtx Q Info)
-> Q Info -> ReaderT TransCtx Q Info
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
typNm
Type
targTyp <- Name -> CompTrans Type
getFullyAppliedType Name
typNm
let nmTyps :: [(Name, Cxt)]
nmTyps = Info -> [(Name, Cxt)]
simplifyDataInf Info
inf
[Clause]
clauses <- ((Name, Cxt) -> CompTrans Clause)
-> [(Name, Cxt)] -> CompTrans [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name -> Cxt -> CompTrans Clause)
-> (Name, Cxt) -> CompTrans Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> Cxt -> CompTrans Clause)
-> (Name, Cxt) -> CompTrans Clause)
-> (Name -> Cxt -> CompTrans Clause)
-> (Name, Cxt)
-> CompTrans Clause
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Name -> Cxt -> CompTrans Clause
mkClause Name
wrap Name
unwrap) [(Name, Cxt)]
nmTyps
let conTyp :: Type
conTyp = Name -> Type
ConT (Name -> Name
transName Name
typNm)
Maybe AnnotationPropInfo
annPropInf <- Getting
(Maybe AnnotationPropInfo) TransCtx (Maybe AnnotationPropInfo)
-> CompTrans (Maybe AnnotationPropInfo)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Maybe AnnotationPropInfo) TransCtx (Maybe AnnotationPropInfo)
forall c. HasTransCtx c => Lens' c (Maybe AnnotationPropInfo)
annotationProp
let instTyp :: Type
instTyp = case Maybe AnnotationPropInfo
annPropInf of
Nothing -> Type
conTyp
Just api :: AnnotationPropInfo
api -> (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT ''(:&:)) [Type
conTyp, AnnotationPropInfo
api AnnotationPropInfo -> Getting Type AnnotationPropInfo Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type AnnotationPropInfo Type
forall c. HasAnnotationPropInfo c => Lens' c Type
annTyp]
[Dec] -> CompTrans [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [ Type -> Dec
famInst Type
targTyp
, [Clause] -> Type -> Dec
inst [Clause]
clauses Type
instTyp
]
where
famInst :: Type -> Dec
famInst targTyp :: Type
targTyp =
TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT Name
targNm) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameLab Name
typNm)) Type
targTyp)
inst :: [Clause] -> Type -> Dec
inst clauses :: [Clause]
clauses instTyp :: Type
instTyp = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD
Maybe Overlap
forall a. Maybe a
Nothing
[]
(Type -> Type -> Type
AppT (Name -> Type
ConT Name
classNm) Type
instTyp)
[Name -> [Clause] -> Dec
FunD Name
funNm [Clause]
clauses]
mapConditionallyReplacing :: [a] -> (a -> b) -> (a -> Bool) -> [b] -> [b]
mapConditionallyReplacing :: [a] -> (a -> b) -> (a -> Bool) -> [b] -> [b]
mapConditionallyReplacing src :: [a]
src f :: a -> b
f p :: a -> Bool
p reps :: [b]
reps = [a] -> [b] -> [b]
go [a]
src [b]
reps
where
go :: [a] -> [b] -> [b]
go [] _ = []
go (x :: a
x:xs :: [a]
xs) (y :: b
y:ys :: [b]
ys) | a -> Bool
p a
x = b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [b]
go [a]
xs [b]
ys
go (x :: a
x:xs :: [a]
xs) l :: [b]
l | Bool -> Bool
not (a -> Bool
p a
x) = a -> b
f a
x b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [b]
go [a]
xs [b]
l
go (_:_ ) [] = String -> [b]
forall a. HasCallStack => String -> a
error "mapConditionallyReplacing: Insufficiently many replacements"
mkClause :: Name -> Name -> Name -> [Type] -> CompTrans Clause
mkClause :: Name -> Name -> Name -> Cxt -> CompTrans Clause
mkClause wrap :: Name
wrap unwrap :: Name
unwrap con :: Name
con tps :: Cxt
tps = do Type -> Bool
isAnn <- CompTrans (Type -> Bool)
getIsAnn
[Name]
nms <- (Type -> CompTrans Name) -> Cxt -> CompTrans [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CompTrans Name -> Type -> CompTrans Name
forall a b. a -> b -> a
const (CompTrans Name -> Type -> CompTrans Name)
-> CompTrans Name -> Type -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "x") Cxt
tps
Name
nmAnn <- ReaderT TransCtx Q Name -> CompTrans Name
forall a. ReaderT TransCtx Q a -> CompTrans a
CompTrans (ReaderT TransCtx Q Name -> CompTrans Name)
-> ReaderT TransCtx Q Name -> CompTrans Name
forall a b. (a -> b) -> a -> b
$ Q Name -> ReaderT TransCtx Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> ReaderT TransCtx Q Name)
-> Q Name -> ReaderT TransCtx Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "a"
Cxt
tps' <- Cxt -> CompTrans Cxt
forall x. Data x => x -> CompTrans x
applyCurSubstitutions Cxt
tps
let nmTps :: [(Name, Type)]
nmTps = [Name] -> Cxt -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
nms Cxt
tps'
[Pat] -> Body -> [Dec] -> Clause
Clause ([Pat] -> Body -> [Dec] -> Clause)
-> CompTrans [Pat] -> CompTrans (Body -> [Dec] -> Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([CompTrans Pat] -> CompTrans [Pat]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [(Type -> Bool) -> [(Name, Type)] -> Name -> CompTrans Pat
pat Type -> Bool
isAnn [(Name, Type)]
nmTps Name
nmAnn]) CompTrans (Body -> [Dec] -> Clause)
-> CompTrans Body -> CompTrans ([Dec] -> Clause)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([(Name, Type)] -> Name -> CompTrans Body
body [(Name, Type)]
nmTps Name
nmAnn) CompTrans ([Dec] -> Clause) -> CompTrans [Dec] -> CompTrans Clause
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> CompTrans [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
where
pat :: (Type -> Bool) -> [(Name, Type)] -> Name -> CompTrans Pat
pat :: (Type -> Bool) -> [(Name, Type)] -> Name -> CompTrans Pat
pat isAnn :: Type -> Bool
isAnn nmTps :: [(Name, Type)]
nmTps nmAnn :: Name
nmAnn = do Bool
isProp <- CompTrans Bool
isPropagatingAnns
if Bool
isProp then
Pat -> CompTrans Pat
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> CompTrans Pat) -> Pat -> CompTrans Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Pat] -> Pat
ConP '(:&:) [Pat
nodeP, Name -> Pat
VarP Name
nmAnn]
else
Pat -> CompTrans Pat
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
nodeP
where
nonAnnNms :: [Name]
nonAnnNms = ((Name, Type) -> Name) -> [(Name, Type)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Name
forall a b. (a, b) -> a
fst ([(Name, Type)] -> [Name]) -> [(Name, Type)] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((Name, Type) -> Bool) -> [(Name, Type)] -> [(Name, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ((Name, Type) -> Bool) -> (Name, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Type -> Bool
isAnn(Type -> Bool) -> ((Name, Type) -> Type) -> (Name, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Name, Type) -> Type
forall a b. (a, b) -> b
snd) [(Name, Type)]
nmTps
nodeP :: Pat
nodeP = Name -> [Pat] -> Pat
ConP (Name -> Name
transName Name
con) ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
nonAnnNms)
body :: [(Name, Type)] -> Name -> CompTrans Body
body :: [(Name, Type)] -> Name -> CompTrans Body
body nmTps :: [(Name, Type)]
nmTps nmAnn :: Name
nmAnn = do Maybe AnnotationPropInfo
annPropInf <- Getting
(Maybe AnnotationPropInfo) TransCtx (Maybe AnnotationPropInfo)
-> CompTrans (Maybe AnnotationPropInfo)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(Maybe AnnotationPropInfo) TransCtx (Maybe AnnotationPropInfo)
forall c. HasTransCtx c => Lens' c (Maybe AnnotationPropInfo)
annotationProp
[Exp]
args <- case Maybe AnnotationPropInfo
annPropInf of
Nothing -> [Exp] -> CompTrans [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp] -> CompTrans [Exp]) -> [Exp] -> CompTrans [Exp]
forall a b. (a -> b) -> a -> b
$ ((Name, Type) -> Exp) -> [(Name, Type)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Type) -> Exp
atom [(Name, Type)]
nmTps
Just api :: AnnotationPropInfo
api -> do Type -> Bool
isAnn <- CompTrans (Type -> Bool)
getIsAnn
let unProp :: Exp -> Int -> [Exp]
unProp = AnnotationPropInfo
api AnnotationPropInfo
-> Getting
(Exp -> Int -> [Exp]) AnnotationPropInfo (Exp -> Int -> [Exp])
-> Exp
-> Int
-> [Exp]
forall s a. s -> Getting a s a -> a
^. Getting
(Exp -> Int -> [Exp]) AnnotationPropInfo (Exp -> Int -> [Exp])
forall c. HasAnnotationPropInfo c => Lens' c (Exp -> Int -> [Exp])
unpropAnn
let annVars :: [(Name, Type)]
annVars = ((Name, Type) -> Bool) -> [(Name, Type)] -> [(Name, Type)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Type -> Bool
isAnn(Type -> Bool) -> ((Name, Type) -> Type) -> (Name, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Name, Type) -> Type
forall a b. (a, b) -> b
snd) [(Name, Type)]
nmTps
let annExps :: [Exp]
annExps = Exp -> Int -> [Exp]
unProp (Name -> Exp
VarE Name
nmAnn) ([(Name, Type)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type)]
annVars)
[Exp] -> CompTrans [Exp]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Exp] -> CompTrans [Exp]) -> [Exp] -> CompTrans [Exp]
forall a b. (a -> b) -> a -> b
$ [(Name, Type)]
-> ((Name, Type) -> Exp)
-> ((Name, Type) -> Bool)
-> [Exp]
-> [Exp]
forall a b. [a] -> (a -> b) -> (a -> Bool) -> [b] -> [b]
mapConditionallyReplacing [(Name, Type)]
nmTps (Name, Type) -> Exp
atom (Type -> Bool
isAnn(Type -> Bool) -> ((Name, Type) -> Type) -> (Name, Type) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Name, Type) -> Type
forall a b. (a, b) -> b
snd) [Exp]
annExps
Body -> CompTrans Body
forall (m :: * -> *) a. Monad m => a -> m a
return (Body -> CompTrans Body) -> Body -> CompTrans Body
forall a b. (a -> b) -> a -> b
$ [Exp] -> Body
makeRhs [Exp]
args
where
makeRhs :: [Exp] -> Body
makeRhs :: [Exp] -> Body
makeRhs args :: [Exp]
args = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
wrap) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
con) [Exp]
args
atom :: (Name, Type) -> Exp
atom :: (Name, Type) -> Exp
atom (x :: Name
x, t :: Type
t) | Type -> Cxt -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
t Cxt
baseTypes = Name -> Exp
VarE Name
x
atom (x :: Name
x, _) = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
unwrap) (Name -> Exp
VarE Name
x)