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

-- | Information used to propagate annotations from terms of third party language library to terms of @cubix-compdata@
--
--   Most libraries associate at most one annotation with each node of a term. However, there are occasional examples
--   where a library attaches multiple annotations to a single node (e.g.: a large construct may have multiple
--   position annotations attached to it). Most of the complexity of this type is constructed to deal with these cases,
--   giving the ability to combine multiple such annotations into a single value, and split a single value into
--   multiple annotations.
data AnnotationPropInfo =
        AnnotationPropInfo {
                             -- | The type of annotation to propagate
                             AnnotationPropInfo -> Type
_annTyp       :: Type

                             -- | A test for whether a type is an annotation to propagate. Usually @(== annType)@.
                           , AnnotationPropInfo -> Type -> Bool
_isAnnotation :: Type -> Bool

                             -- | Annotation propagator: takes a list of TH expressions (and their types)
                             --   which at runtime evaluate to the annotations (as reported by isAnn) accompanying
                             --   a term. Returns a single TH expression constructing a new annotation to
                             --   be attached to the translated @cubix-compdata@ term.
                             --
                             --   `defaultPropAnn` suffices for most purposes, but users have the option to
                             --   define an annotation propagator which combines multiple annotations into one.
                           , AnnotationPropInfo -> [(Exp, Type)] -> Exp
_propAnn      :: [(Exp, Type)] -> Exp

                             -- | Annotation unpropagator; inverts @propAnn@. Takes a TH expression
                             --   which at runtime evaluates to the annotation accompanying a @cubix-compdata@ term,
                             --   along with the number of distinct annotation values to be included in the target
                             --   term. Returns a list of TH expressions which construct the annotations to be attached
                             --   to the untranslated term.
                             --
                             --   `defaultUnpropAnn` usually suffices, but users have the option
                             --   to define an annotation unpropagator which splits a single value into multiple.
                           , AnnotationPropInfo -> Exp -> Int -> [Exp]
_unpropAnn    :: Exp -> Int -> [Exp]
                           }

-- | Configuration parameters for @comptrans@
data TransCtx = TransCtx {
                           -- | For internal use only
                           TransCtx -> [Name]
_allTypes      :: [Name]

                           -- | Used primarily for compatibility with libraries such as @language-c@,
                           --   where datatypes all take a parameter, e.g.: `CStmt a`, where @a@ is an annotation
                           --   parameter which essentially only has one value (e.g.: @SourceSpan@). This
                           --   substitutions map will be used to replace all such type variables with concrete types,
                           --   grounding all such datatypes to be kind @*@.
                           --
                           --   Other integrations that require this map for the same reason include @language-lua@
                           --   and @language-python@
                         , TransCtx -> Map Name Type
_substitutions :: Map Name Type

                           -- | A set of names to not generate definitions for, so that they may be handled
                           --   manually.
                         , TransCtx -> Set Name
_excludedNames :: Set Name                  -- ^

                           -- | When this is set, `deriveTrans` and `deriveUntrans` will generate code that
                           --   converts annotated terms in the integrated library into annotated @cubix-compdata@ terms,
                           --   with annotations given by @`(:&:)`@.
                           --
                           --   See documentation of `withAnnotationProp` and `AnnotationPropInfo`.
                         , TransCtx -> Maybe AnnotationPropInfo
_annotationProp :: Maybe AnnotationPropInfo -- ^
                         }

makeClassy ''AnnotationPropInfo
makeClassy ''TransCtx
  
defaultTransCtx :: TransCtx
defaultTransCtx :: TransCtx
defaultTransCtx = 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
                           }


-- | The central monad of @comptrans@, defined as the `Q` monad with
--   additional configuration parameters
newtype CompTrans a = CompTrans { forall a. CompTrans a -> ReaderT TransCtx Q a
unCompTrans :: ReaderT TransCtx Q a }
  deriving ( (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
$cfmap :: forall a b. (a -> b) -> CompTrans a -> CompTrans b
fmap :: forall a b. (a -> b) -> CompTrans a -> CompTrans b
$c<$ :: forall a b. a -> CompTrans b -> CompTrans a
<$ :: forall a b. a -> CompTrans b -> CompTrans a
Functor, Functor CompTrans
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
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
$cpure :: forall a. a -> CompTrans a
pure :: forall a. a -> CompTrans a
$c<*> :: forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
<*> :: forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
$cliftA2 :: forall a b c.
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
liftA2 :: forall a b c.
(a -> b -> c) -> CompTrans a -> CompTrans b -> CompTrans c
$c*> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
*> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
$c<* :: forall a b. CompTrans a -> CompTrans b -> CompTrans a
<* :: forall a b. CompTrans a -> CompTrans b -> CompTrans a
Applicative, Applicative CompTrans
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
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
$c>>= :: forall a b. CompTrans a -> (a -> CompTrans b) -> CompTrans b
>>= :: forall a b. CompTrans a -> (a -> CompTrans b) -> CompTrans b
$c>> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
>> :: forall a b. CompTrans a -> CompTrans b -> CompTrans b
$creturn :: forall a. a -> CompTrans a
return :: forall a. a -> CompTrans a
Monad, Monad CompTrans
Monad CompTrans =>
(forall a. [Char] -> CompTrans a) -> MonadFail CompTrans
forall a. [Char] -> CompTrans a
forall (m :: * -> *).
Monad m =>
(forall a. [Char] -> m a) -> MonadFail m
$cfail :: forall a. [Char] -> CompTrans a
fail :: forall a. [Char] -> CompTrans a
MonadFail, Monad CompTrans
Monad CompTrans =>
(forall a. IO a -> CompTrans a) -> MonadIO CompTrans
forall a. IO a -> CompTrans a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> CompTrans a
liftIO :: forall a. IO a -> CompTrans a
MonadIO, MonadReader TransCtx )

-- | Runs a @comptrans@ computation, resulting in a Template Haskell command
--   which creates some number of declarations.
--
--   `CompTrans` values are created by `deriveMulti`, `deriveTrans`, and `deriveUntrans`,
--   and may be configured using functions such as `withSubstitutions`
runCompTrans :: CompTrans a -> Q a
runCompTrans :: forall a. CompTrans a -> Q a
runCompTrans 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                   -- ^ @annTyp@, the annotation type being propagated
                   -> (Type -> Bool)         -- ^ A test for whether a type is an annotation to propagate. Usually @(== annType)@.
                   -> ([(Exp, Type)] -> Exp) -- ^ Annotation propogater. Usually constructed with `defaultPropAnn`. See `AnnotationPropInfo`.
                   -> (Exp -> Int -> [Exp])  -- ^ Annotation unpropater. Usuallyl `defaultUnpropAnn`.  See `AnnotationPropInfo`
                   -> CompTrans a            -- ^ code generating @comptrans@ declarations
                   -> CompTrans a
withAnnotationProp :: forall a.
Type
-> (Type -> Bool)
-> ([(Exp, Type)] -> Exp)
-> (Exp -> Int -> [Exp])
-> CompTrans a
-> CompTrans a
withAnnotationProp Type
annTyp Type -> Bool
isAnn [(Exp, Type)] -> Exp
propAnn Exp -> Int -> [Exp]
unpropAnn = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall a. (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)
Lens' TransCtx (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))

-- | Runs a @comptrans@ declaration with a given set of type variable substitutions
withSubstitutions :: Map.Map Name Type -> CompTrans a -> CompTrans a
withSubstitutions :: forall a. Map Name Type -> CompTrans a -> CompTrans a
withSubstitutions Map Name Type
substs = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall a. (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)
Lens' TransCtx (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 :: forall a. [Name] -> CompTrans a -> CompTrans a
withAllTypes [Name]
names = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall a. (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]
Lens' TransCtx [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)

-- | Runs a @comptrans@ declaration with a given set of excluded namess
withExcludedNames :: Set Name -> CompTrans a -> CompTrans a
withExcludedNames :: forall a. Set Name -> CompTrans a -> CompTrans a
withExcludedNames Set Name
names = (TransCtx -> TransCtx) -> CompTrans a -> CompTrans a
forall a. (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)
Lens' TransCtx (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)

-- | Names that should be excluded from an AST hierarchy.
--   Includes base types, basic containers (`Maybe`, `Either`), and `Text`/`ByteString`.
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]


{-
   Types which should be translated into functorial form.
  
   Both String and its expansion are present because
   expandSyn threw errors
 -}
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 Type -> Bool
isAnn = Type -> CompTrans Type
gl
  where
    gl :: Type -> CompTrans Type
gl (AppT f :: Type
f@(AppT Type
_ Type
_) Type
t) = (Type -> Type -> Type)
-> CompTrans Type -> CompTrans Type -> CompTrans Type
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Type -> Type -> Type
AppT (Type -> CompTrans Type
gl Type
f) (Type -> CompTrans Type
gl Type
t)
    gl (AppT c :: Type
c@(ConT Name
n) Type
t)
      | Type -> Bool
isAnn Type
t = Type -> CompTrans Type
gl Type
c
      | Bool
otherwise = do
          [Name]
names <- Getting [Name] TransCtx [Name] -> CompTrans [Name]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Name] TransCtx [Name]
forall c. HasTransCtx c => Lens' c [Name]
Lens' TransCtx [Name]
allTypes
          if Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
n [Name]
names then
            Type -> CompTrans Type
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans 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) -> CompTrans Type -> CompTrans Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CompTrans Type
gl Type
t
    gl (AppT Type
f Type
t) = Type -> Type -> Type
AppT Type
f (Type -> Type) -> CompTrans Type -> CompTrans Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> CompTrans Type
gl Type
t
    gl Type
ListT      = Type -> CompTrans Type
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ListT
    gl (TupleT Int
n) = Type -> CompTrans Type
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TupleT Int
n
    gl (ConT Name
n)   = Type -> CompTrans Type
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> CompTrans Type) -> Type -> CompTrans 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 Type
x          = [Char] -> CompTrans Type
forall a. [Char] -> CompTrans a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> CompTrans Type) -> [Char] -> CompTrans Type
forall a b. (a -> b) -> a -> b
$ [Char]
"When deriving multi-sorted compositional data type, found unsupported type in AST: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
x


transName :: Name -> Name
transName :: Name -> Name
transName = ([Char] -> [Char]) -> Name -> Name
modNameBase [Char] -> [Char]
forall a. a -> a
id

nameLab :: Name -> Name
nameLab :: Name -> Name
nameLab = ([Char] -> [Char]) -> Name -> Name
modNameBase ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"L")

smartConstrName :: Name -> Name
smartConstrName :: Name -> Name
smartConstrName = ([Char] -> [Char]) -> Name -> Name
modNameBase (Char
'i'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:)

modNameBase :: (String -> String) -> Name -> Name
modNameBase :: ([Char] -> [Char]) -> Name -> Name
modNameBase [Char] -> [Char]
f = [Char] -> Name
mkName ([Char] -> Name) -> (Name -> [Char]) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
f ([Char] -> [Char]) -> (Name -> [Char]) -> Name -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameBase

simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf (TyConI (DataD [Type]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
cons [DerivClause]
_))   = (Con -> (Name, [Type])) -> [Con] -> [(Name, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
extractCon [Con]
cons
simplifyDataInf (TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ Con
con [DerivClause]
_)) = [Con -> (Name, [Type])
extractCon Con
con]
simplifyDataInf Info
_                               = [Char] -> [(Name, [Type])]
forall a. HasCallStack => [Char] -> a
error [Char]
"Attempted to derive multi-sorted compositional data type for non-nullary datatype"

extractCon :: Con -> (Name, [Type])
extractCon :: Con -> (Name, [Type])
extractCon (NormalC Name
nm [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 Name
nm [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
Lens VarBangType VarBangType Type Type
_3) [VarBangType]
vsts)
extractCon (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c)  = Con -> (Name, [Type])
extractCon Con
c
extractCon Con
_                = [Char] -> (Name, [Type])
forall a. HasCallStack => [Char] -> a
error [Char]
"Unsupported constructor type encountered"

getTypeArgs :: Name -> CompTrans [Name]
getTypeArgs :: Name -> CompTrans [Name]
getTypeArgs 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 (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
nm
  case Info
inf of
    TyConI (DataD [Type]
_ Name
_ [TyVarBndr BndrVis]
tvs Maybe Type
_ [Con]
_ [DerivClause]
_)    -> [Name] -> CompTrans [Name]
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> CompTrans [Name]) -> [Name] -> CompTrans [Name]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getNames [TyVarBndr BndrVis]
tvs
    TyConI (NewtypeD [Type]
_ Name
_ [TyVarBndr BndrVis]
tvs Maybe Type
_ Con
_ [DerivClause]
_) -> [Name] -> CompTrans [Name]
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> CompTrans [Name]) -> [Name] -> CompTrans [Name]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> [Name]
forall a. [TyVarBndr a] -> [Name]
getNames [TyVarBndr BndrVis]
tvs
    Info
_                             -> [Name] -> CompTrans [Name]
forall a. a -> CompTrans a
forall (m :: * -> *) a. Monad m => a -> m a
return []

getNames :: [TyVarBndr a] -> [Name]
getNames :: forall a. [TyVarBndr a] -> [Name]
getNames = (TyVarBndr a -> Name) -> [TyVarBndr a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr a -> Name
forall a. TyVarBndr a -> Name
getName
  where
    getName :: TyVarBndr a -> Name
    getName :: forall a. TyVarBndr a -> Name
getName (PlainTV Name
n a
_)    = Name
n
    getName (KindedTV Name
n a
_ Type
_) = Name
n

containsAll :: (Ord a) => Map a b -> [a] -> Bool
containsAll :: forall a b. Ord a => Map a b -> [a] -> Bool
containsAll 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 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)
Lens' TransCtx (Map Name Type)
substitutions
  [Name]
typeArgs <- Name -> CompTrans [Name]
getTypeArgs Name
nm
  return $ (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 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)
Lens' TransCtx (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)
Lens' TransCtx (Maybe AnnotationPropInfo)
annotationProp
  case Maybe AnnotationPropInfo
mApi of
    Maybe AnnotationPropInfo
Nothing  -> (Type -> Bool) -> CompTrans (Type -> Bool)
forall a. a -> CompTrans a
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 AnnotationPropInfo
api -> (Type -> Bool) -> CompTrans (Type -> Bool)
forall a. a -> CompTrans a
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)
Lens' AnnotationPropInfo (Type -> Bool)
isAnnotation

-- | A default annotation propagator: Assumes 0 or 1 annotations per constructor
--   Returns the default annotation or copies the given annotation as appropriate.
defaultPropAnn :: Exp -- ^ default annotation, to be used on terms that do not have an annotation
               -> [(Exp, Type)] -> Exp
defaultPropAnn :: Exp -> [(Exp, Type)] -> Exp
defaultPropAnn Exp
defAnn [(Exp, Type)]
tps = case [(Exp, Type)]
tps of
      []       -> Exp
defAnn
      [(Exp
x, Type
_)] -> Exp
x
      [(Exp, Type)]
_        -> [Char] -> Exp
forall a. HasCallStack => [Char] -> a
error [Char]
"comptrans: Multiple annotation fields detected in constructor"

-- | A default annotation unpropagator: Assumes 0 or 1 annotations per constructor. If 1 annotation given, copies it.
defaultUnpropAnn :: Exp -> Int -> [Exp]
defaultUnpropAnn :: Exp -> Int -> [Exp]
defaultUnpropAnn Exp
_ Int
0 = []
defaultUnpropAnn Exp
x Int
1 = [Exp
x]
defaultUnpropAnn Exp
_ Int
_ = [Char] -> [Exp]
forall a. HasCallStack => [Char] -> a
error [Char]
"comptrans: Multiple annotation fields detected in constructor"

isVar :: Type -> Bool
isVar :: Type -> Bool
isVar (VarT Name
_) = Bool
True
isVar Type
_        = Bool
False

applySubsts :: (Data x) => Map Name Type -> x -> x
applySubsts :: forall x. Data x => Map Name Type -> x -> x
applySubsts 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 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 Type
res -> Type
res
      Maybe Type
Nothing  -> Type
t
    subst1 Type
t          = Type
t

applyCurSubstitutions :: (Data x) => x -> CompTrans x
applyCurSubstitutions :: forall x. Data x => x -> CompTrans x
applyCurSubstitutions 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)
Lens' TransCtx (Map Name Type)
substitutions CompTrans (x -> x) -> CompTrans x -> CompTrans x
forall a b. CompTrans (a -> b) -> CompTrans a -> CompTrans b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> x -> CompTrans x
forall a. a -> CompTrans a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x