{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Trans.Util
(
AnnotationPropInfo(..)
, annTyp
, isAnnotation
, propAnn
, unpropAnn
, TransCtx(..)
, allTypes
, substitutions
, excludedNames
, annotationProp
, withAllTypes
, withSubstitutions
, withExcludedNames
, withAnnotationProp
, CompTrans(..)
, runCompTrans
, standardExcludedNames
, baseTypes
, getLab
, transName
, nameLab
, smartConstrName
, modNameBase
, simplifyDataInf
, getTypeArgs
, getNames
, containsAll
, getFullyAppliedType
, getIsAnn
, isPropagatingAnns
, defaultPropAnn
, defaultUnpropAnn
, isVar
, applySubsts
, applyCurSubstitutions
) where
import Control.Lens ( (^.), (.~), _3, makeClassy, view )
import Control.Monad ( liftM2 )
import Control.Monad.IO.Class ( MonadIO )
import Control.Monad.Reader ( MonadReader, ReaderT(..), local )
import Control.Monad.Trans ( lift )
import Data.Data ( Data )
import Data.Generics ( everywhere, mkT )
import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Maybe ( isJust )
import Data.Set ( Set, fromList )
import Language.Haskell.TH.Syntax hiding ( lift )
import Data.ByteString ( ByteString )
import Data.Text ( Text )
data AnnotationPropInfo =
AnnotationPropInfo {
AnnotationPropInfo -> Type
_annTyp :: Type
, AnnotationPropInfo -> Type -> Bool
_isAnnotation :: Type -> Bool
, AnnotationPropInfo -> [(Exp, Type)] -> Exp
_propAnn :: [(Exp, Type)] -> Exp
, AnnotationPropInfo -> Exp -> Int -> [Exp]
_unpropAnn :: Exp -> Int -> [Exp]
}
data TransCtx = TransCtx {
TransCtx -> [Name]
_allTypes :: [Name]
, TransCtx -> Map Name Type
_substitutions :: Map Name Type
, TransCtx -> Set Name
_excludedNames :: Set Name
, TransCtx -> Maybe AnnotationPropInfo
_annotationProp :: Maybe AnnotationPropInfo
}
makeClassy ''AnnotationPropInfo
makeClassy ''TransCtx
defaultTransCtx :: TransCtx
defaultTransCtx :: TransCtx
defaultTransCtx = TransCtx :: [Name]
-> Map Name Type
-> Set Name
-> Maybe AnnotationPropInfo
-> TransCtx
TransCtx {
_allTypes :: [Name]
_allTypes = []
, _substitutions :: Map Name Type
_substitutions = Map Name Type
forall k a. Map k a
Map.empty
, _excludedNames :: Set Name
_excludedNames = Set Name
standardExcludedNames
, _annotationProp :: Maybe AnnotationPropInfo
_annotationProp = Maybe AnnotationPropInfo
forall a. Maybe a
Nothing
}
newtype CompTrans a = CompTrans { CompTrans a -> ReaderT TransCtx Q a
unCompTrans :: ReaderT TransCtx Q a }
deriving ( a -> CompTrans b -> CompTrans a
(a -> b) -> CompTrans a -> CompTrans b
(forall a b. (a -> b) -> CompTrans a -> CompTrans b)
-> (forall a b. a -> CompTrans b -> CompTrans a)
-> Functor CompTrans
forall a b. a -> CompTrans b -> CompTrans a
forall a b. (a -> b) -> CompTrans a -> CompTrans b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CompTrans b -> CompTrans a
$c<$ :: forall a b. a -> CompTrans b -> CompTrans a
fmap :: (a -> b) -> CompTrans a -> CompTrans b
$cfmap :: forall a b. (a -> b) -> CompTrans a -> CompTrans b
Functor, Functor CompTrans
a -> CompTrans a
Functor CompTrans =>
(forall a. a -> CompTrans a)
-> (forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b)
-> (forall a b c.
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c)
-> (forall a b. CompTrans a -> CompTrans b -> CompTrans b)
-> (forall a b. CompTrans a -> CompTrans b -> CompTrans a)
-> Applicative CompTrans
CompTrans a -> CompTrans b -> CompTrans b
CompTrans a -> CompTrans b -> CompTrans a
CompTrans (a -> b) -> CompTrans a -> CompTrans b
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
forall a. a -> CompTrans a
forall a b. CompTrans a -> CompTrans b -> CompTrans a
forall a b. CompTrans a -> CompTrans b -> CompTrans b
forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
forall a b c.
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: CompTrans a -> CompTrans b -> CompTrans a
$c<* :: forall a b. CompTrans a -> CompTrans b -> CompTrans a
*> :: CompTrans a -> CompTrans b -> CompTrans b
$c*> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
liftA2 :: (a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
$cliftA2 :: forall a b c.
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
<*> :: CompTrans (a -> b) -> CompTrans a -> CompTrans b
$c<*> :: forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
pure :: a -> CompTrans a
$cpure :: forall a. a -> CompTrans a
$cp1Applicative :: Functor CompTrans
Applicative, Applicative CompTrans
a -> CompTrans a
Applicative CompTrans =>
(forall a b. CompTrans a -> (a -> CompTrans b) -> CompTrans b)
-> (forall a b. CompTrans a -> CompTrans b -> CompTrans b)
-> (forall a. a -> CompTrans a)
-> Monad CompTrans
CompTrans a -> (a -> CompTrans b) -> CompTrans b
CompTrans a -> CompTrans b -> CompTrans b
forall a. a -> CompTrans a
forall a b. CompTrans a -> CompTrans b -> CompTrans b
forall a b. CompTrans a -> (a -> CompTrans b) -> CompTrans b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> CompTrans a
$creturn :: forall a. a -> CompTrans a
>> :: CompTrans a -> CompTrans b -> CompTrans b
$c>> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
>>= :: CompTrans a -> (a -> CompTrans b) -> CompTrans b
$c>>= :: forall a b. CompTrans a -> (a -> CompTrans b) -> CompTrans b
$cp1Monad :: Applicative CompTrans
Monad, Monad CompTrans
Monad CompTrans =>
(forall a. String -> CompTrans a) -> MonadFail CompTrans
String -> CompTrans a
forall a. String -> CompTrans a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> CompTrans a
$cfail :: forall a. String -> CompTrans a
$cp1MonadFail :: Monad CompTrans
MonadFail, Monad CompTrans
Monad CompTrans =>
(forall a. IO a -> CompTrans a) -> MonadIO CompTrans
IO a -> CompTrans a
forall a. IO a -> CompTrans a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> CompTrans a
$cliftIO :: forall a. IO a -> CompTrans a
$cp1MonadIO :: Monad CompTrans
MonadIO, MonadReader TransCtx )
runCompTrans :: CompTrans a -> Q a
runCompTrans :: CompTrans a -> Q a
runCompTrans m :: CompTrans a
m = ReaderT TransCtx Q a -> TransCtx -> Q a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (CompTrans a -> ReaderT TransCtx Q a
forall a. CompTrans a -> ReaderT TransCtx Q a
unCompTrans CompTrans a
m) TransCtx
defaultTransCtx
withAnnotationProp :: Type
-> (Type -> Bool)
-> ([(Exp, Type)] -> Exp)
-> (Exp -> Int -> [Exp])
-> CompTrans a
-> CompTrans a
withAnnotationProp :: Type
-> (Type -> Bool)
-> ([(Exp, Type)] -> Exp)
-> (Exp -> Int -> [Exp])
-> CompTrans a
-> CompTrans a
withAnnotationProp annTyp :: Type
annTyp isAnn :: Type -> Bool
isAnn propAnn :: [(Exp, Type)] -> Exp
propAnn unpropAnn :: Exp -> Int -> [Exp]
unpropAnn = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Maybe AnnotationPropInfo -> Identity (Maybe AnnotationPropInfo))
-> TransCtx -> Identity TransCtx
forall c. HasTransCtx c => Lens' c (Maybe AnnotationPropInfo)
annotationProp ((Maybe AnnotationPropInfo -> Identity (Maybe AnnotationPropInfo))
-> TransCtx -> Identity TransCtx)
-> Maybe AnnotationPropInfo -> TransCtx -> TransCtx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (AnnotationPropInfo -> Maybe AnnotationPropInfo
forall a. a -> Maybe a
Just (AnnotationPropInfo -> Maybe AnnotationPropInfo)
-> AnnotationPropInfo -> Maybe AnnotationPropInfo
forall a b. (a -> b) -> a -> b
$ Type
-> (Type -> Bool)
-> ([(Exp, Type)] -> Exp)
-> (Exp -> Int -> [Exp])
-> AnnotationPropInfo
AnnotationPropInfo Type
annTyp Type -> Bool
isAnn [(Exp, Type)] -> Exp
propAnn Exp -> Int -> [Exp]
unpropAnn))
withSubstitutions :: Map.Map Name Type -> CompTrans a -> CompTrans a
withSubstitutions :: Map Name Type -> CompTrans a -> CompTrans a
withSubstitutions substs :: Map Name Type
substs = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Map Name Type -> Identity (Map Name Type))
-> TransCtx -> Identity TransCtx
forall c. HasTransCtx c => Lens' c (Map Name Type)
substitutions ((Map Name Type -> Identity (Map Name Type))
-> TransCtx -> Identity TransCtx)
-> Map Name Type -> TransCtx -> TransCtx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Name Type
substs)
withAllTypes :: [Name] -> CompTrans a -> CompTrans a
withAllTypes :: [Name] -> CompTrans a -> CompTrans a
withAllTypes names :: [Name]
names = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (([Name] -> Identity [Name]) -> TransCtx -> Identity TransCtx
forall c. HasTransCtx c => Lens' c [Name]
allTypes (([Name] -> Identity [Name]) -> TransCtx -> Identity TransCtx)
-> [Name] -> TransCtx -> TransCtx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Name]
names)
withExcludedNames :: Set Name -> CompTrans a -> CompTrans a
withExcludedNames :: Set Name -> CompTrans a -> CompTrans a
withExcludedNames names :: Set Name
names = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((Set Name -> Identity (Set Name)) -> TransCtx -> Identity TransCtx
forall c. HasTransCtx c => Lens' c (Set Name)
excludedNames ((Set Name -> Identity (Set Name))
-> TransCtx -> Identity TransCtx)
-> Set Name -> TransCtx -> TransCtx
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set Name
names)
standardExcludedNames :: Set Name
standardExcludedNames :: Set Name
standardExcludedNames = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
fromList [''Maybe, ''Either, ''Int, ''Integer, ''Bool, ''Char, ''Double, ''Text, ''ByteString]
baseTypes :: [Type]
baseTypes :: [Type]
baseTypes = [ Name -> Type
ConT ''Int
, Name -> Type
ConT ''Bool
, Name -> Type
ConT ''Char
, Name -> Type
ConT ''Float
, Name -> Type
ConT ''Double
, Name -> Type
ConT ''Integer
, Name -> Type
ConT ''String
, Type -> Type -> Type
AppT Type
ListT (Name -> Type
ConT ''Char)
, Name -> Type
ConT ''Text
, Name -> Type
ConT ''ByteString
]
getLab :: (Type -> Bool) -> Type -> CompTrans Type
getLab :: (Type -> Bool) -> Type -> CompTrans Type
getLab isAnn :: Type -> Bool
isAnn = Type -> CompTrans Type
forall (f :: * -> *) s.
(MonadReader s f, HasTransCtx s, MonadFail f) =>
Type -> f Type
gl
where
gl :: Type -> f Type
gl (AppT f :: Type
f@(AppT _ _) t :: Type
t) = (Type -> Type -> Type) -> f Type -> f Type -> f Type
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Type -> Type -> Type
AppT (Type -> f Type
gl Type
f) (Type -> f Type
gl Type
t)
gl (AppT c :: Type
c@(ConT n :: Name
n) t :: Type
t)
| Type -> Bool
isAnn Type
t = Type -> f Type
gl Type
c
| Bool
otherwise = do
[Name]
names <- Getting [Name] s [Name] -> f [Name]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Name] s [Name]
forall c. HasTransCtx c => Lens' c [Name]
allTypes
if Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
n [Name]
names then
Type -> f Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> f Type) -> Type -> f Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameLab Name
n
else
Type -> Type -> Type
AppT (Name -> Type
ConT Name
n) (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
gl Type
t
gl (AppT f :: Type
f t :: Type
t) = Type -> Type -> Type
AppT Type
f (Type -> Type) -> f Type -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> f Type
gl Type
t
gl ListT = Type -> f Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ListT
gl (TupleT n :: Int
n) = Type -> f Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> f Type) -> Type -> f Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TupleT Int
n
gl (ConT n :: Name
n) = Type -> f Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> f Type) -> Type -> f Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Name
nameLab Name
n
gl x :: Type
x = String -> f Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f Type) -> String -> f Type
forall a b. (a -> b) -> a -> b
$ "When deriving multi-sorted compositional data type, found unsupported type in AST: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
x
transName :: Name -> Name
transName :: Name -> Name
transName = (String -> String) -> Name -> Name
modNameBase String -> String
forall a. a -> a
id
nameLab :: Name -> Name
nameLab :: Name -> Name
nameLab = (String -> String) -> Name -> Name
modNameBase (String -> String -> String
forall a. [a] -> [a] -> [a]
++"L")
smartConstrName :: Name -> Name
smartConstrName :: Name -> Name
smartConstrName = (String -> String) -> Name -> Name
modNameBase ('i'Char -> String -> String
forall a. a -> [a] -> [a]
:)
modNameBase :: (String -> String) -> Name -> Name
modNameBase :: (String -> String) -> Name -> Name
modNameBase f :: String -> String
f = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf (TyConI (DataD _ _ _ _ cons :: [Con]
cons _)) = (Con -> (Name, [Type])) -> [Con] -> [(Name, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
extractCon [Con]
cons
simplifyDataInf (TyConI (NewtypeD _ _ _ _ con :: Con
con _)) = [Con -> (Name, [Type])
extractCon Con
con]
simplifyDataInf _ = String -> [(Name, [Type])]
forall a. HasCallStack => String -> a
error "Attempted to derive multi-sorted compositional data type for non-nullary datatype"
extractCon :: Con -> (Name, [Type])
(NormalC nm :: Name
nm sts :: [BangType]
sts) = (Name
nm, (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
sts)
extractCon (RecC nm :: Name
nm vsts :: [VarBangType]
vsts) = (Name
nm, (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (VarBangType -> Getting Type VarBangType Type -> Type
forall s a. s -> Getting a s a -> a
^. Getting Type VarBangType Type
forall s t a b. Field3 s t a b => Lens s t a b
_3) [VarBangType]
vsts)
extractCon (ForallC _ _ c :: Con
c) = Con -> (Name, [Type])
extractCon Con
c
extractCon _ = String -> (Name, [Type])
forall a. HasCallStack => String -> a
error "Unsupported constructor type encountered"
getTypeArgs :: Name -> CompTrans [Name]
getTypeArgs :: Name -> CompTrans [Name]
getTypeArgs nm :: Name
nm = 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
nm
case Info
inf of
TyConI (DataD _ _ tvs :: [TyVarBndr]
tvs _ _ _) -> [Name] -> CompTrans [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> CompTrans [Name]) -> [Name] -> CompTrans [Name]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [Name]
getNames [TyVarBndr]
tvs
TyConI (NewtypeD _ _ tvs :: [TyVarBndr]
tvs _ _ _) -> [Name] -> CompTrans [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> CompTrans [Name]) -> [Name] -> CompTrans [Name]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [Name]
getNames [TyVarBndr]
tvs
_ -> [Name] -> CompTrans [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return []
getNames :: [TyVarBndr] -> [Name]
getNames :: [TyVarBndr] -> [Name]
getNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
getName
where
getName :: TyVarBndr -> Name
getName :: TyVarBndr -> Name
getName (PlainTV n :: Name
n) = Name
n
getName (KindedTV n :: Name
n _) = Name
n
containsAll :: (Ord a) => Map a b -> [a] -> Bool
containsAll :: Map a b -> [a] -> Bool
containsAll mp :: Map a b
mp = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> Map a b -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map a b
mp)
getFullyAppliedType :: Name -> CompTrans Type
getFullyAppliedType :: Name -> CompTrans Type
getFullyAppliedType nm :: Name
nm = do
Map Name Type
substs <- Getting (Map Name Type) TransCtx (Map Name Type)
-> CompTrans (Map Name Type)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Name Type) TransCtx (Map Name Type)
forall c. HasTransCtx c => Lens' c (Map Name Type)
substitutions
[Name]
typeArgs <- Name -> CompTrans [Name]
getTypeArgs Name
nm
Type -> CompTrans Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans Type
forall a b. (a -> b) -> a -> b
$ (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
nm) (Map Name Type -> [Type] -> [Type]
forall x. Data x => Map Name Type -> x -> x
applySubsts Map Name Type
substs ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
typeArgs)
isPropagatingAnns :: CompTrans Bool
isPropagatingAnns :: CompTrans Bool
isPropagatingAnns = Maybe AnnotationPropInfo -> Bool
forall a. Maybe a -> Bool
isJust (Maybe AnnotationPropInfo -> Bool)
-> CompTrans (Maybe AnnotationPropInfo) -> CompTrans Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
getIsAnn :: CompTrans (Type -> Bool)
getIsAnn :: CompTrans (Type -> Bool)
getIsAnn = do
Maybe AnnotationPropInfo
mApi <- 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
case Maybe AnnotationPropInfo
mApi of
Nothing -> (Type -> Bool) -> CompTrans (Type -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Bool) -> CompTrans (Type -> Bool))
-> (Type -> Bool) -> CompTrans (Type -> Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Type -> Bool
forall a b. a -> b -> a
const Bool
False
Just api :: AnnotationPropInfo
api -> (Type -> Bool) -> CompTrans (Type -> Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Type -> Bool) -> CompTrans (Type -> Bool))
-> (Type -> Bool) -> CompTrans (Type -> Bool)
forall a b. (a -> b) -> a -> b
$ AnnotationPropInfo
api AnnotationPropInfo
-> Getting (Type -> Bool) AnnotationPropInfo (Type -> Bool)
-> Type
-> Bool
forall s a. s -> Getting a s a -> a
^. Getting (Type -> Bool) AnnotationPropInfo (Type -> Bool)
forall c. HasAnnotationPropInfo c => Lens' c (Type -> Bool)
isAnnotation
defaultPropAnn :: Exp
-> [(Exp, Type)] -> Exp
defaultPropAnn :: Exp -> [(Exp, Type)] -> Exp
defaultPropAnn defAnn :: Exp
defAnn tps :: [(Exp, Type)]
tps = case [(Exp, Type)]
tps of
[] -> Exp
defAnn
[(x :: Exp
x, _)] -> Exp
x
_ -> String -> Exp
forall a. HasCallStack => String -> a
error "comptrans: Multiple annotation fields detected in constructor"
defaultUnpropAnn :: Exp -> Int -> [Exp]
defaultUnpropAnn :: Exp -> Int -> [Exp]
defaultUnpropAnn _ 0 = []
defaultUnpropAnn x :: Exp
x 1 = [Exp
x]
defaultUnpropAnn _ _ = String -> [Exp]
forall a. HasCallStack => String -> a
error "comptrans: Multiple annotation fields detected in constructor"
isVar :: Type -> Bool
isVar :: Type -> Bool
isVar (VarT _) = Bool
True
isVar _ = Bool
False
applySubsts :: (Data x) => Map Name Type -> x -> x
applySubsts :: Map Name Type -> x -> x
applySubsts mp :: Map Name Type
mp = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Type -> Type) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT Type -> Type
subst1)
where
subst1 :: Type -> Type
subst1 :: Type -> Type
subst1 t :: Type
t@(VarT n :: Name
n) = case Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name Type
mp of
Just res :: Type
res -> Type
res
Nothing -> Type
t
subst1 t :: Type
t = Type
t
applyCurSubstitutions :: (Data x) => x -> CompTrans x
applyCurSubstitutions :: x -> CompTrans x
applyCurSubstitutions x :: x
x = Map Name Type -> x -> x
forall x. Data x => Map Name Type -> x -> x
applySubsts (Map Name Type -> x -> x)
-> CompTrans (Map Name Type) -> CompTrans (x -> x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Map Name Type) TransCtx (Map Name Type)
-> CompTrans (Map Name Type)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Map Name Type) TransCtx (Map Name Type)
forall c. HasTransCtx c => Lens' c (Map Name Type)
substitutions CompTrans (x -> x) -> CompTrans x -> CompTrans x
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> CompTrans x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x