#define DBG_NAMES 0
#define DBG_TYPES 0
#define INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION 1
#define EXCLUDE_POLYMORPHIC_TYPES 1
#define SHOW_CONSTRAINT 0
module Seqaid.TH (
#if __GLASGOW_HASKELL__ >= 710
module Seqaid.TH_710 ,
#else
seqaidTH ,
seqaidValidate ,
strInstancesTH ,
bindsIncludedTH ,
#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS
noinlineTH ,
#endif
module Seqaid.Runtime ,
module Seqaid.Ann ,
#endif
) where
#if __GLASGOW_HASKELL__ >= 710
import Seqaid.TH_710
#else
import Language.Haskell.TH
import Language.Haskell.TH.Syntax ( qLocation )
#if SEQAIDPP_TYPES
import Seqaid.TH_extra ( names )
#else
import Seqaid.TH_extra ( names )
#endif
import Data.Generics ( listify, everywhere, mkT )
#if SEQABLE_ONLY
import Generics.SOP.Universe ( Generic )
#endif
#if NFDATAN_ONLY
import Control.DeepSeq.Bounded ( NFDataN )
#else
import Control.DeepSeq.Bounded ( NFDataP )
#endif
import Seqaid.Runtime ( seqaidDispatch, SiteID )
import Seqaid.Ann
import Data.Maybe
import Data.Either
import Data.List ( intercalate, nub, nubBy )
import Control.Monad ( liftM, zipWithM, foldM )
#if 0
import qualified GHC.Environment as GHC ( getFullArgs )
#endif
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
import Text.Regex.PCRE
import Data.Array ( (!) )
import Data.Array ( indices )
import Debug.Trace ( trace )
import qualified Type as GHC ( Type )
firstWarningPassed :: IORef Bool
firstWarningPassed = unsafePerformIO $ newIORef False
seqaidInstancesTH :: Q [Dec]
seqaidInstancesTH = do
#if SEQABLE_ONLY
is <- getInstances ''Generics.SOP.Universe.Generic
#else
#if NFDATAN_ONLY
is <- getInstances ''NFDataN
#else
is <- getInstances ''NFDataP
#endif
#endif
dss <- instancesToSeqinjDecls is
let ds = concat dss
return ds
strInstancesTH :: Q [Dec]
strInstancesTH = do
#if SEQABLE_ONLY
is <- getInstances ''Generics.SOP.Universe.Generic
#else
#if NFDATAN_ONLY
is <- getInstances ''NFDataN
#else
is <- getInstances ''NFDataP
#endif
#endif
ss <- instancesToTypeStrings is
#if 1
exp <- [e| SeqaidAnnAvailableInstances ss |]
let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)
return [pragma_decl]
#else
let lites = map (\x -> LitE (StringL x)) ss
vp <- newName "seqaid_instance_strings"
let dec = ValD (VarP vp) (NormalB (ListE lites)) []
return [dec]
#endif
bindsIncludedTH :: [String] -> Q [Dec]
bindsIncludedTH bns = do
exp <- [e| SeqaidAnnBindsIncluded bns |]
let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)
return [pragma_decl]
seqaidValidate :: [Name] -> Q [Dec]
seqaidValidate names = do
infos' <- mapM reify names
infos <- mapM seqaidValidate' infos'
return []
where
seqaidValidate' :: Info -> Q Info
seqaidValidate' t = do
case t of
TyConI (TySynD name tyVarBndrs typ) -> error $ "seqaidpp: type synonym in instances list (seqaid.config):\n " ++ pprint name
_ -> return t
#if 1 || SEQAIDPP_TYPES
#if 1
#if 1
seqaidTH :: [Q Type] -> Q [Dec]
seqaidTH types_actions = do
#else
seqaidTH :: [Type] -> Q [Dec]
seqaidTH types = do
#endif
#else
seqaidTH :: [String] -> Q [Dec]
seqaidTH type_strs = do
#endif
#else
seqaidTH :: Q [Dec]
seqaidTH = do
#endif
#if SEQAIDPP_TYPES
types <- mapM runQ types_actions
#else
let types = []
#endif
modname <- fmap loc_module qLocation
runIO $ putStrLn $ "Included in seqaid harness: " ++ modname
do
#if 0
fullargs <- runIO $ GHC.getFullArgs
if not $ elem "-fplugin=Seqaid.Plugin" fullargs
&& elem ("-fplugin-opt=Seqaid.Plugin:" ++ modname) fullargs
then return []
else do
#endif
#if 1 || SEQAIDPP_TYPES
#if 0
#if 0
Just types_name <- lookupValueName "seqaid_types"
types <- reify types_name
#endif
types <- mapM (liftM fromJust . lookupTypeName) type_strs
#else
let type_strs = map pprint types
#endif
#endif
#if 1 || SEQAIDPP_TYPES
#if TH_TYPE_IN_TYPES_ANN
#if 0
#elif 1
ghc_types <- $(types)
sats_exp <- [e| SeqaidAnnTypes ghc_types |]
#elif 0
sats_exp <- [e| SeqaidAnnTypes $(types) |]
#elif 0
let ghc_types = map (\x -> $(x)) types
sats_exp <- [e| SeqaidAnnTypes ghc_types |]
#endif
#else
sats_exp <- [e| SeqaidAnnTypes type_strs |]
#endif
#if DBG_TYPES
runIO $ putStrLn $ " :|: sats_exp =\n" ++ pprint sats_exp
#endif
let sats_pragma_decl = PragmaD (AnnP ModuleAnnotation sats_exp)
#endif
#if INFER_TOP_LEVEL_TYPES
ns <- names :: Q [Name]
ents_names <- mapM ( makeNameType . (\x->Left x) ) ns :: Q [Either Name (Maybe Name,Type)]
#if DBG_NAMES
runIO $ putStrLn $ "Top-level names in scope:\n" ++ show ns
#endif
#else
let ents_names = []
#endif
#if SEQAIDPP_TYPES
ents_types <- mapM ( makeNameType_types . (\x->Right x) ) types :: Q [Either Name (Maybe Name,Type)]
#else
let ents_types = []
#endif
#if DBG_TYPES
runIO $ putStrLn $ " !! length ents_names=" ++ (show $ length ents_names)
runIO $ putStrLn $ " !! length ents_types=" ++ (show $ length ents_types)
#endif
let ents = ents_names ++ ents_types
#if DBG_TYPES || DBG_NAMES
runIO $ putStrLn $ show ents
#endif
let nts = rights ents
if null nts
then do
#if DBG_NAMES
runIO $ putStrLn $ "modulespection:names = []"
#endif
return []
else do
#if DBG_NAMES
let ss = map (\ (n,t) -> pprint n ++ " :: " ++ pprint t) nts :: [String]
let ss' = intercalate "\n " ss
runIO $ putStrLn $ "modulespection:names = \n " ++ ss'
#endif
sidtyp <- [t| SiteID |]
([ann]:dss') <- manifestSeqinjDecls sidtyp nts
let dss = dss'
#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION
(clsd:instd:[]) <- manifestDummyClassAndInstance sidtyp dss
#endif
#if SEQAIDPP_TYPES
let ds = sats_pragma_decl : ann : clsd : instd : reverse (concat $ map reverse dss)
#else
#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION
let ds = ann : clsd : instd : reverse (concat $ map reverse dss)
#else
let ds = ann : reverse (concat $ map reverse dss)
#endif
#endif
return ds
instancesToSeqinjDecls :: [InstanceDec] -> Q [[Dec]]
instancesToSeqinjDecls ids = zipWithM instancesToSeqinjDecl' [0,1..] ids
where
instancesToSeqinjDecl' :: Int -> InstanceDec -> Q [Dec]
instancesToSeqinjDecl' idx (InstanceD ctx t ds) = do
let (AppT _ t2) = t
(seqinj_dec:_) <- [d| seqinj = seqaidDispatch :: () -> () |]
let (ValD (VarP vp1) (NormalB (SigE ae1 (AppT (AppT ArrowT _) _))) [])
= seqinj_dec
#if 0
let vp1' = vp1
#else
let vp1s = show vp1
let (vp1s1,vp1s2) = break (=='_') vp1s
let vp1s' = "seqinjinst_" ++ show idx
vp1' <- newName vp1s'
#endif
let free_tvars_t2 = getFreeTVars t2
let bind_tvars_t2 = map bindTVars free_tvars_t2
let ctx2 = make_ctx Nothing free_tvars_t2 ctx
let seqinj_tdec
= SigD vp1' (ForallT bind_tvars_t2 ctx2 (AppT (AppT ArrowT t2) t2))
let seqinj_fdec
= (ValD (VarP vp1') (NormalB ae1 ) [])
return [seqinj_tdec, seqinj_fdec]
instancesToTypeStrings :: [InstanceDec] -> Q [String]
instancesToTypeStrings ids = zipWithM instancesToTypeString' [0,1..] ids
where
instancesToTypeString' :: Int -> InstanceDec -> Q String
instancesToTypeString' idx (InstanceD ctx t ds) = do
let (AppT _ t2) = t
return $ pprint t
bindTVars :: Type -> TyVarBndr
bindTVars (VarT name) = PlainTV name
bindTVars _ = error "bindTVars: unexpected!"
getFreeTVars :: Type -> [Type]
getFreeTVars t = listify f t
where
f :: Type -> Bool
f x@(VarT name) = True
f x = False
getInstances :: Name -> Q [InstanceDec]
getInstances typ = do
ClassI _ instances <- reify typ
return instances
#if 0
showInstances :: Name -> Q Exp
showInstances typ = do
ins <- getInstances typ
return . LitE . stringL $ show ins
#endif
makeNameType :: Either Name Type -> Q (Either Name (Maybe Name,Type))
makeNameType (Right _) = error "makeNameType: Right unexpected!"
makeNameType enm@(Left nm) = do
modname <- fmap loc_module qLocation
#if 0
!_ <- trace ("nm="++pprint nm++" modname="++modname) $ return ()
if False && takeQuals (pprint nm) /= modname
then do
!_ <- trace "HERE-1" $ return ()
return $ Left nm
else do
#else
do
#endif
#if 1
rnm <- reify nm
let mnmt
= case rnm of
VarI nm_ t_ mdec_ fxty_ ->
if takeQuals (show nm_) /= modname
then Nothing
else Just (nm_,t_)
#if 0
ClassOpI nm_ t_ parentnm_ fxty_ ->
if takeQuals (show nm_) /= modname
then Nothing else Just (nm_,t_)
DataConI nm_ t_ parentnm_ fxty_ ->
if takeQuals (show nm_) /= modname
then Nothing else Just (nm_,t_)
_ -> Nothing
#else
_ -> Nothing
#endif
#else
rnm@(VarI nm_ t_ mdec_ fxty_) <- reify nm
#endif
if isNothing mnmt
then do
return $ Left nm
else do
let Just (nm_,t_) = mnmt
#if 0
let snm_ = pprint nm_
let st_ = pprint t_
runIO $ putStrLn $ " ********* " ++ snm_ ++ " " ++ st_
#endif
return $ Right (Just nm_,t_)
makeNameType_types :: Either Name Type -> Q (Either Name (Maybe Name,Type))
makeNameType_types (Left _) = error "makeNameType_types: Left unexpected!"
#if 1
makeNameType_types enm@(Right typaboo) = do
return $ Right (Nothing,typaboo)
#else
makeNameType_types enm@(Right nm) = do
modname <- fmap loc_module qLocation
rnm <- reify nm
!_ <- trace ("<><><><> " ++ pprint rnm) $ return ()
let mnmt
= case rnm of
VarI nm_ t_ mdec_ fxty_ -> error "makeNameType_types: VarI unexpected!"
... unfinished ...
TyConI dec_ -> case dec_ of
DataD cxt name tyvarbndrs cons name ->
NewtypeD Cxt Name [TyVarBndr] Con [Name]
TySynD Name [TyVarBndr] Type
_ -> Nothing
if isNothing mnmt
then do
return $ Left nm
else do
let Just (nm_,t_) = mnmt
#if 0
let snm_ = pprint nm_
let st_ = pprint t_
runIO $ putStrLn $ " ********* " ++ snm_ ++ " " ++ st_
#endif
return $ Right (Just nm_,t_)
#endif
manifestSeqinjDecls :: Type -> [(Maybe Name,Type)] -> Q [[Dec]]
manifestSeqinjDecls sidtyp nts = do
mod <- thisModule
modname <- fmap loc_module qLocation
reiannbad <- reifyAnnotations (AnnLookupModule mod) :: Q [SeqaidAnnIncludeList]
if not $ null reiannbad
then do
error $ "seqaid: illegal SeqaidAnnIncludeList annotation"
else do
reiann <- reifyAnnotations (AnnLookupModule mod) :: Q [SeqaidAnnExclude]
--ValueAnnotation
let zlst' = map (\ (SeqaidAnnExclude s) -> s) reiann
let zlst'' = map (\ s -> if elem '.' s then s else modname ++ ('.':s)) zlst'
let zlst = zlst''
(injdecls,excorincnms) <- liftM fst $
( foldM
( \ y@((injdecls_, excorincnms_), yidx) x ->
do
eideclst <- manifestSeqinjDecl' zlst yidx x
case eideclst of
Left nm -> return ((injdecls_, excorincnms_), yidx)
#if 1
Right d -> case fst x of
Nothing -> return ((d:injdecls_, excorincnms_), 1+yidx)
Just nm -> return ((d:injdecls_, nm:excorincnms_), 1+yidx)
#else
Right d -> let nm = fst x in
return ((d:injdecls_, nm:excorincnms_), 1+yidx)
#endif
)
(([],[]),0)
:: [(Maybe Name,Type)] -> Q (([[Dec]],[Name]),Int) )
nts
let ss = map pprint excorincnms
let ss' = ss
exp <- [e| SeqaidAnnIncludeList ss' |]
let pragma_decl = PragmaD (AnnP ModuleAnnotation exp)
return ([pragma_decl] : injdecls)
where
manifestSeqinjDecl' :: [String] -> Int -> (Maybe Name,Type) -> Q (Either Name [Dec])
manifestSeqinjDecl' zlst idx (mnm,t) = do
#if 0
data Type = ForallT [TyVarBndr] Cxt Type
| AppT Type Type
| SigT Type Kind
| VarT Name
| ConT Name
| PromotedT Name
| TupleT Int
| UnboxedTupleT Int
| ArrowT
| ListT
| PromotedTupleT Int
| PromotedNilT
| PromotedConsT
| StarT
| ConstraintT
| LitT TyLit
#endif
let st = pprint t
let nm = fromJust mnm
let snm = pprint nm
#if 0
runIO $ putStrLn $ "mnm = " ++ show mnm ++ "\nst = " ++ st
runIO $ putStrLn $ "zlst = " ++ show zlst
#endif
if isJust mnm && elem snm zlst
then do return (Left nm)
else do
#if ! EXCLUDE_POLYMORPHIC_TYPES
let t2 = t
do
#else
mt2 <- case t of
(ForallT _ _ _) -> do
if isNothing mnm
then return $ Just t
else do
firstwarnpassed <- runIO $ readIORef firstWarningPassed
if firstwarnpassed
then reportWarning $ "seqaid: omitting declaration from auto-harness:\n " ++ snm ++ " :: " ++ beautify st ++ "\n Polymorphic types not yet supported by the plugin."
else reportWarning $ "seqaid: omitting declaration from auto-harness:\n " ++ snm ++ " :: " ++ beautify st ++ "\n Sorry, polymorphic types not yet supported by the plugin.\n If you need this declaration to be included in the harness,\n please manually instrument with \" seqaid $ \" at the front of the\n RHS of its binding. (For technical reasons, this warning will\n still appear unless you also put\n {-# ANN module (SeqaidAnnExclude \"" ++ dropQuals snm ++ "\") #-}\n someplace in the same module; or just ignore the warning.)"
#if 0
++ " Pass seqaidDispatch a distinct, negative Int as\n first argument. (Negative keys are reserved for this eventuality.)"
#endif
runIO $ modifyIORef' firstWarningPassed (const True)
return Nothing
_ -> return $ Just t
if isNothing mt2 then return $ Left nm
else do
let t2 = followArrows $ fromJust mt2
#endif
(seqinj_dec:_) <- [d| seqinj = seqaidDispatch :: SiteID -> () -> () |]
#if 0
let (ValD (VarP vp1) (NormalB (SigE ae1 ( AppT (AppT ArrowT sidtyp) ( AppT (AppT ArrowT _) _))))) [])
= seqinj_dec
#else
let (ValD (VarP vp1) (NormalB (SigE ae1 (
AppT
(AppT ArrowT sidtyp)
( AppT
(AppT ArrowT _)
_
)
)
)) [])
= seqinj_dec
#endif
#if 0
( AppT
(AppT ArrowT sidtyp)
( AppT
(AppT ArrowT typ_)
typ_
)
)
#endif
let vp1s = show vp1
let (vp1s1,vp1s2) = break (=='_') vp1s
let vp1s' = "seqinj_" ++ show idx
vp1' <- newName vp1s'
#if 1
t' <- makeSeqinjType Nothing sidtyp t2
let seqinj_tdec = SigD vp1' t'
#else
let seqinj_tdec
= SigD vp1' (AppT (AppT ArrowT t2) t2)
#endif
let seqinj_fdec
= ValD (VarP vp1') (NormalB ae1) []
return $ Right [seqinj_tdec, seqinj_fdec]
makeSeqinjType :: Maybe Name -> Type -> Type -> Q Type
makeSeqinjType mn sidtyp tt@(ForallT tyvarbndr_lst ctx typ) = do
let n = fromJust mn
let free_tvars_typ' = getFreeTVars typ
#if 1
let free_tvars_typ = free_tvars_typ'
#else
let free_tvars_typ
| isNothing mb = free_tvars_typ'
| PlainTV n <- b = filter (==(VarT n)) free_tvars_typ'
| KindedTV n k <- b = filter (==(VarT n)) free_tvars_typ'
#endif
#if 1
let blah1 = map (\ (VarT n) -> show n) (free_tvars_typ :: [Type]) :: [String]
let blah2 = nub blah1 :: [String]
blah3 <- mapM newName (map (take 1) blah2) :: Q [Name]
blah4 <- mapM (\ n -> return $ VarT n) blah3 :: Q [Type]
let bind_tvars_typ = blah4
let orig_tyvars = nub free_tvars_typ
let fresh_tyvars = bind_tvars_typ
#else
new_tvars_typ
<- fmap (\ n -> return $ VarT n) $
(( mapM newName $
(( nub $
(( map (\ (VarT n) -> show n) (free_tvars_typ :: [Type])) :: [String] ) ) :: [String] )
:: Q [Name]))
#endif
let binding = map bindTVars bind_tvars_typ
let (AppT _ typ_) = typ
let typ_' = substTyVars (orig_tyvars,fresh_tyvars) typ_
let typ' | isNothing mn
= let typ_ = substTyVars (orig_tyvars,fresh_tyvars) typ
in
ForallT
binding
(make_ctx (Just (orig_tyvars,fresh_tyvars)) bind_tvars_typ ctx)
(
( AppT
(AppT ArrowT sidtyp)
( AppT
(AppT ArrowT typ_)
typ_
)
)
)
| otherwise
= let (AppT _ typ_) = typ
typ_' = substTyVars (orig_tyvars,fresh_tyvars) typ_
in
ForallT
binding
(make_ctx (Just (orig_tyvars,fresh_tyvars)) bind_tvars_typ ctx)
#if 0
(AppT (AppT ArrowT (VarT n))
(AppT (AppT ArrowT typ_') typ_')
)
#else
#if 0
( trace "BOO-2" $
( AppT
(AppT ArrowT (VarT n))
( AppT
(AppT ArrowT sidtyp)
typ_'
)
)
)
#else
(AppT (AppT ArrowT (VarT n)) typ_')
#endif
#endif
return typ'
makeSeqinjType mn sidtyp tt@typ = do
let n = fromJust mn
let free_tvars_typ = getFreeTVars typ
if null free_tvars_typ
then do
let typ' | isNothing mn
= ( AppT
(AppT ArrowT sidtyp)
( AppT
(AppT ArrowT typ)
typ
)
)
| otherwise
#if 0
= AppT
(AppT ArrowT (VarT n))
(AppT (AppT ArrowT typ) typ)
#else
#if 0
= trace "BOO-3" $ ( AppT
(AppT ArrowT (VarT n))
( AppT
(AppT ArrowT sidtyp)
typ
)
)
#else
= (AppT (AppT ArrowT (VarT n)) typ)
#endif
#endif
return typ'
else do
#if 1
error $ "makeSeqinjType: Nothing and free vars"
#else
runIO $ putStrLn $ " >OTHER:non-null> " ++ pprint tt
let bind_tvars_typ = map bindTVars free_tvars_typ
let typ' = ForallT
bind_tvars_typ
(make_ctx (Just ([],[])) free_tvars_typ [])
(AppT (AppT ArrowT typ) typ)
let typ' = AppT (AppT ArrowT typ) typ
return typ'
#endif
substTyVars :: ([Type],[Type]) -> Type -> Type
substTyVars (orig,fresh) t = everywhere (mkT fg) t
where
fg :: Type -> Type
fg (VarT n)
| isNothing mfn = error "substTyVars: lookup failed!"
| otherwise = VarT $ fromJust mfn
where
mfn = h n orig fresh
h :: Name -> [Type] -> [Type] -> Maybe Name
h n [] _ = Nothing
h n ((VarT o):os) ((VarT f):fs)
| n == o = trace (show o ++ " ----->> " ++ show f) $ Just f
| otherwise = h n os fs
fg x = x
make_ctx :: Maybe ([Type],[Type]) -> [Type] -> [Pred] -> [Pred]
make_ctx mof free_tvars_typ ctx = ctx2
where
ctx2
= ctx'
#if SEQABLE_ONLY
++ map (\ v -> ClassP name_SOP_Generic [v]) free_tvars_typ
#else
#if NFDATAN_ONLY
++ map (\ v -> ClassP name_NFDataN [v]) free_tvars_typ
#else
++ map (\ v -> ClassP name_Typeable [v]) free_tvars_typ
++ map (\ v -> ClassP name_NFDataN [v]) free_tvars_typ
++ map (\ v -> ClassP name_NFData [v]) free_tvars_typ
++ map (\ v -> ClassP name_NFDataP [v]) free_tvars_typ
#endif
#endif
#if SHOW_CONSTRAINT
++ map (\ v -> ClassP name_Show [v]) free_tvars_typ
#endif
where
j p | ClassP n ts <- p = ClassP n $ map (substTyVars (orig,fresh)) ts
| EqualP t1 t2 <- p = EqualP ((substTyVars (orig,fresh)) t1) ((substTyVars (orig,fresh)) t1)
ctx_ | isNothing mof = ctx
| otherwise = map j ctx
Just (orig,fresh) = mof
!_ = trace (show ctx_) $ ()
ctx' = (
id
#if SEQABLE_ONLY
. filter (\ (ClassP name ts) -> show name /= "Generic")
. filter (\ (ClassP name ts) -> show name /= "Generics.SOP.Universe.Generic")
#if SHOW_TYPE
. filter (\ (ClassP name ts) -> show name /= "Typeable")
#endif
#else
#if NFDATAN_ONLY
. filter (\ (ClassP name ts) -> show name /= "NFDataN")
. filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")
#if SHOW_TYPE
. filter (\ (ClassP name ts) -> show name /= "Typeable")
#endif
#else
. filter (\ (ClassP name ts) -> show name /= "Typeable")
. filter (\ (ClassP name ts) -> show name /= "NFDataN")
. filter (\ (ClassP name ts) -> show name /= "NFData")
. filter (\ (ClassP name ts) -> show name /= "NFDataP")
. filter (\ (ClassP name ts) -> show name /= "Data.Typeable.Internal.Typeable")
. filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataN.NFDataN")
. filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.NFData")
. filter (\ (ClassP name ts) -> show name /= "Control.DeepSeq.Bounded.NFDataP.NFDataP")
#endif
#endif
#if SHOW_CONSTRAINT
. filter (\ (ClassP name ts) -> show name /= "Show")
. filter (\ (ClassP name ts) -> show name /= "GHC.Show.Show")
#endif
)
ctx_
name_NFDataP = mkName "NFDataP"
name_NFDataN = mkName "NFDataN"
name_NFData = mkName "NFData"
name_Typeable = mkName "Typeable"
name_Show = mkName "Show"
name_SOP_Generic = mkName "Generics.SOP.Universe.Generic"
showNTs :: [(Name,Type)] -> String
showNTs nts = ss'
where
ss = map (\ (n,t) -> pprint n ++ " :: " ++ pprint t) nts
ss' = intercalate "\n" ss
followArrows :: Type -> Type
followArrows (AppT (AppT ArrowT t1) t2) = followArrows t2
followArrows t = t
#if INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION
manifestDummyClassAndInstance :: Type -> [[Dec]] -> Q [Dec]
manifestDummyClassAndInstance sidtyp dss = do
modname <- fmap loc_module qLocation
let modname' = map (\x -> if x == '.' then '_' else x) modname
an <- newName "a"
(sigs,defs) <- liftM fst $
( foldM
( \ y@((sigs_, defs_), i) dec ->
do
let [tdec, fdec] = dec
let (SigD vp_s t_s) = tdec
let (ValD (VarP vp_v) (NormalB ae_v) []) = fdec
mn <- newName $ "seqinj_meth_" ++ show i
#if 1
#if 1
t_s' <- makeSeqinjType (Just an) sidtyp t_s
#else
let t_s'' = AppT (AppT ArrowT (VarT an)) t_s
t_s' <- makeSeqinjType (Just an) t_s''
#endif
#else
let t_s' = AppT (AppT ArrowT (VarT tv)) t_s
#endif
let s = SigD mn t_s'
vv <- newName "x"
sid <- newName "sid"
let d = FunD
mn
[ Clause
[WildP, VarP sid, VarP vv]
(NormalB
(AppE
#if NO_TOP_LEVEL_SEQINJ_DUMMIES
(AppE (VarE $ mkName "Seqaid.Runtime.seqaidDispatch") (VarE sid))
#else
(AppE (VarE vp_v) (VarE sid))
#endif
(VarE vv)
)
)
[]
]
return ((s:sigs_, d:defs_), 1+i)
)
(([],[]),1+length dss)
:: [[Dec]] -> Q (([Dec],[Dec]),Int) )
dss
cn <- newName $ "SeqinjDummyClass_" ++ modname'
let cdec = ClassD [] cn [PlainTV an] [] sigs
let idec = InstanceD [] (AppT (ConT cn) (TupleT 0)) defs
return [cdec, idec]
#endif
dropQuals :: String -> String
dropQuals = reverse . takeWhile (/= '.') . reverse
takeQuals :: String -> String
takeQuals = reverse . drop 1 . dropWhile (/= '.') . reverse
beautify :: String -> String
beautify s = s_
where
marr1 = (s =~ "^forall ") :: MatchArray
(a1,b1) = (marr1!0)
marr2 = (s =~ "=> ") :: MatchArray
(a2,b2) = (marr2!0)
s_ | null $ indices marr1 = s
| null $ indices marr2 = s
| otherwise
= dropWhile (\x -> x==' '||x=='\t'||x=='\n')
$ drop (a2+b2) s
#if TRY_INJECT_NOINLINE_ON_REQUESTED_BINDS
noinlineTH :: [String] -> Q [Dec]
noinlineTH nms = do
mapM
(\x -> do Just nm <- lookupValueName x
return $ PragmaD $ InlineP nm NoInline FunLike AllPhases)
nms
#endif
#endif