{-# 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

--------------------------------------------------------------------------------


-- |
-- Creates an @untranslate@ function inverting the @translate@ function
-- created by @deriveTrans@.
--
-- @
-- import qualified Foo as F
-- type ArithTerm = Term (Sum '[Arith, Atom, Lit])
-- deriveUntrans [''F.Arith, ''F.Atom, ''F.Lit] (TH.ConT ''ArithTerm)
-- @
--
-- will create
--
-- @
-- type family Targ l
-- newtype T l = T {t :: Targ l}
--
-- class Untrans f where
--   untrans :: Alg f t
--
-- untranslate :: ArithTerm l -> Targ l
-- untranslate = t . cata untrans
--
-- type instance Targ ArithL = F.Arith
-- instance Untrans Arith where
--   untrans (Add x y) = T $ F.Add (t x) (t y)
--
-- type instance Targ AtomL = F.Atom
-- instance Untrans Atom where
--   untrans (Var s)   = T $ F.Var s
--   untrans (Const x) = T $ F.Const (t x)
--
-- type instance Targ LitL = F.Lit
-- instance Untrans Lit where
--   untrans (Lit n) = T $ F.Lit n
-- @
--
-- With annotation propagations on, it will instead produce
-- @untranslate :: Term (Arith :&: Ann) l -> Targ l Ann@
--
-- where @Ann@ is the provided annotation type.
--
-- Note that you will need to manually provide an instance @(All Untrans fs) => Untrans (Sum fs)@
-- due to phase issues. (Or @(All Untrans (DistAnn fs a)) => Untrans (Sum fs :&: a)@, if you
-- are propagating annotations.)
--
deriveUntrans :: [Name] -> Type -> CompTrans [Dec]
deriveUntrans :: [Name] -> Type -> CompTrans [Dec]
deriveUntrans [Name]
names 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance Name
classNm Name
fnNm Name
wrapNm Name
unwrapNm Name
targNm) [Name]
names
                              return $ [[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 String
"Targ"
    wrapNm :: Name
wrapNm = String -> Name
mkName String
"T"
    unwrapNm :: Name
unwrapNm = String -> Name
mkName String
"t"
    untranslateNm :: Name
untranslateNm = String -> Name
mkName String
"untranslate"
    classNm :: Name
classNm = String -> Name
mkName String
"Untrans"
    fnNm :: Name
fnNm = String -> Name
mkName String
"untrans"

{- type family Targ l -}
mkTarg :: Name -> CompTrans [Dec]
mkTarg :: Name -> CompTrans [Dec]
mkTarg 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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"i"
                   return [TypeFamilyHead -> Dec
OpenTypeFamilyD (Name
-> [TyVarBndr BndrVis]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
targNm [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
i BndrVis
BndrReq] FamilyResultSig
NoSig Maybe InjectivityAnn
forall a. Maybe a
Nothing)]

{- newtype T l = T { t :: Targ l } -}
mkWrapper :: Name -> Name -> Name -> CompTrans [Dec]
mkWrapper :: Name -> Name -> Name -> CompTrans [Dec]
mkWrapper Name
tpNm Name
fNm 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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"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   = [Type]
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
NewtypeD [] Name
tpNm [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
i BndrVis
BndrReq] Maybe Type
forall a. Maybe a
Nothing Con
con []
                               [Dec] -> CompTrans [Dec]
forall a. a -> CompTrans a
forall (f :: * -> *) a. Applicative f => a -> f a
return [Dec
nt]
{-
  untranslate :: JavaTerm l -> Targ l
  untranslate = t . cata untrans
-}
mkFn :: Name -> Type -> Name -> Name -> Name -> CompTrans [Dec]
mkFn :: Name -> Type -> Name -> Name -> Name -> CompTrans [Dec]
mkFn Name
fnNm Type
term Name
targNm Name
fldNm Name
untransNm = [CompTrans Dec] -> CompTrans [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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 -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
fnNm ([TyVarBndr Specificity] -> Q [Type] -> Q Type -> Q Type
forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m [Type] -> m Type -> m Type
forallT [Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
i Specificity
SpecifiedSpec] ([Type] -> Q [Type]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []) (Q Type -> Q Type
typ (Q Type -> Q Type) -> Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
i))

    typ :: Q Type -> Q Type
    typ :: Q Type -> Q Type
typ Q Type
i = [t| $Q Type
term' $Q Type
i -> $Q Type
targ $Q Type
i |]

    term' :: Q Type
term' = Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
term
    targ :: Q Type
targ = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
$ Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
fnNm) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []

    body :: Q Exp
body = [| $Q Exp
fld . cata $Q Exp
untrans |]

    fld :: Q Exp
fld = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fldNm
    untrans :: Q Exp
untrans = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
untransNm

{-
  class Untrans f where
    untrans :: Alg f T
-}
mkClass :: Name -> Name -> Name -> CompTrans [Dec]
mkClass :: Name -> Name -> Name -> CompTrans [Dec]
mkClass Name
classNm Name
funNm 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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"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 a. a -> CompTrans a
forall (f :: * -> *) a. Applicative f => a -> f a
return [[Type] -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Dec] -> Dec
ClassD [] Name
classNm [Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
f BndrVis
BndrReq] [] [Dec
funDec]]

{-
  type instance Targ CompilationUnitL = J.CompilationUnit
  instance Untrans CompilationUnit where
    untrans (CompilationUnit x y z) = T $ J.CompilationUnit (t x) (t y) (t z)
-}
mkInstance :: Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance :: Name -> Name -> Name -> Name -> Name -> Name -> CompTrans [Dec]
mkInstance Name
classNm Name
funNm Name
wrap Name
unwrap Name
targNm 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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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, [Type])]
nmTyps = Info -> [(Name, [Type])]
simplifyDataInf Info
inf
                                                       [Clause]
clauses <- ((Name, [Type]) -> CompTrans Clause)
-> [(Name, [Type])] -> CompTrans [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Name -> [Type] -> CompTrans Clause)
-> (Name, [Type]) -> CompTrans Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Name -> [Type] -> CompTrans Clause)
 -> (Name, [Type]) -> CompTrans Clause)
-> (Name -> [Type] -> CompTrans Clause)
-> (Name, [Type])
-> CompTrans Clause
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Name -> [Type] -> CompTrans Clause
mkClause Name
wrap Name
unwrap) [(Name, [Type])]
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)
Lens' TransCtx (Maybe AnnotationPropInfo)
annotationProp
                                                       let instTyp :: Type
instTyp = case Maybe AnnotationPropInfo
annPropInf of
                                                                       Maybe AnnotationPropInfo
Nothing  -> Type
conTyp
                                                                       Just AnnotationPropInfo
api -> (Type -> Type -> Type) -> Type -> [Type] -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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
Lens' AnnotationPropInfo Type
annTyp]
                                                       return [ Type -> Dec
famInst Type
targTyp
                                                              , [Clause] -> Type -> Dec
inst [Clause]
clauses Type
instTyp
                                                              ]
  where
    famInst :: Type -> Dec
famInst 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 [Clause]
clauses Type
instTyp =  Maybe Overlap -> [Type] -> 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 :: forall a b. [a] -> (a -> b) -> (a -> Bool) -> [b] -> [b]
mapConditionallyReplacing [a]
src a -> b
f a -> Bool
p [b]
reps = [a] -> [b] -> [b]
go [a]
src [b]
reps
  where
    go :: [a] -> [b] -> [b]
go [] [b]
_                      = []
    go (a
x:[a]
xs) (b
y:[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 (a
x:[a]
xs) [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 (a
_:[a]
_ ) []                 = String -> [b]
forall a. HasCallStack => String -> a
error String
"mapConditionallyReplacing: Insufficiently many replacements"

mkClause :: Name -> Name -> Name -> [Type] -> CompTrans Clause
mkClause :: Name -> Name -> Name -> [Type] -> CompTrans Clause
mkClause Name
wrap Name
unwrap Name
con [Type]
tps = do Type -> Bool
isAnn <- CompTrans (Type -> Bool)
getIsAnn
                                  [Name]
nms <- (Type -> CompTrans Name) -> [Type] -> CompTrans [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x") [Type]
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 (m :: * -> *) a. Monad m => m a -> ReaderT TransCtx m a
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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
                                  [Type]
tps' <- [Type] -> CompTrans [Type]
forall x. Data x => x -> CompTrans x
applyCurSubstitutions [Type]
tps
                                  let nmTps :: [(Name, Type)]
nmTps = [Name] -> [Type] -> [(Name, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
nms [Type]
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
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 a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Dec] -> CompTrans [Dec]
forall a. a -> CompTrans a
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 Type -> Bool
isAnn [(Name, Type)]
nmTps Name
nmAnn = do Bool
isProp <- CompTrans Bool
isPropagatingAnns
                               if Bool
isProp then
                                 Pat -> CompTrans Pat
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> CompTrans Pat) -> Pat -> CompTrans Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> [Pat] -> Pat
ConP '(:&:) [] [Pat
nodeP, Name -> Pat
VarP Name
nmAnn]
                                else
                                 Pat -> CompTrans Pat
forall a. a -> CompTrans a
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 -> [Type] -> [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 [(Name, Type)]
nmTps 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)
Lens' TransCtx (Maybe AnnotationPropInfo)
annotationProp
                          [Exp]
args <- case Maybe AnnotationPropInfo
annPropInf of
                                    Maybe AnnotationPropInfo
Nothing  -> [Exp] -> CompTrans [Exp]
forall a. a -> CompTrans a
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 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])
Lens' AnnotationPropInfo (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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Name, Type)]
annVars)
                                                   [Exp] -> CompTrans [Exp]
forall a. a -> CompTrans a
forall (f :: * -> *) a. Applicative f => a -> f 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
                          return $ [Exp] -> Body
makeRhs [Exp]
args
      where
        makeRhs :: [Exp] -> Body
        makeRhs :: [Exp] -> Body
makeRhs [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 b a. (b -> a -> b) -> b -> [a] -> b
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 (Name
x, Type
t) | Type -> [Type] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Type
t [Type]
baseTypes = Name -> Exp
VarE Name
x
    atom (Name
x, Type
_)                    = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
unwrap) (Name -> Exp
VarE Name
x)