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

{- type family Targ l -}
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)]

{- newtype T l = T { t :: Targ l } -}
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]
{-
  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 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

{-
  class Untrans f where
    untrans :: Alg f T
-}
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]]

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