MODULE {TestTrans2} {demoSwf} {}

INCLUDE "ByteCodeTrfBase.ag"

WRAPPER SwfFile

{
import Data.Maybe
import Text.Regex.TDFA
}

{
demoSwf :: Options -> [SymbolTables] -> SwfFile -> SwfFile
demoSwf opts tbls m = out where
  inh = Inh_SwfFile { opts_Inh_SwfFile = opts, tbls_Inh_SwfFile = tbls }
  sem = sem_SwfFile m
  syn = wrap_SwfFile sem inh
  out = output_Syn_SwfFile syn
}

SEM Instruction | Virtual

-- | search mechanism in this implementation based on explicit name's lookup, it doesn't use QName datatype
--   inst.inj1 : InjRoot
--   inst.inj1 = @loc.runInject $ do
-- 			let methodRef = Ref $ ctxMethodId $ ctxMethod @loc.ctxInfo
-- 			let tbls = ctxTbls @loc.ctxInfo
-- 			let sig = sigName $ lookupMethod methodRef tbls
-- 			let methodName = case sig of
-- 					  Just a -> lookupString a tbls
-- 					  Nothing -> "###"	  
-- 			when (@kind.self == VirtKind_BeginBody) $ do
-- 				debug (ctxParents @loc.ctxInfo)
				
-- 			when ((methodName =~ "(do)*(Trace)" :: Bool) && (@kind.self == VirtKind_BeginBody)) $ do 
-- 			  str <- declString ("test!!!")
-- 			  l <- freshLabel
-- 			  callTrace str
-- 			  label l



-- | alternative implementation the same idea as in previous code, that are commented 			
--   inst.inj1 : InjRoot
--   inst.inj1 = @loc.runInject $ do
-- 			let nref = Ref $ ctxMethodId $ ctxMethod @loc.ctxInfo
-- 			let tbls = ctxTbls @loc.ctxInfo
-- 			let qname = showByteStr $ qName $ toQName tbls nref
-- 			when (@kind.self == VirtKind_BeginBody) $ do
-- 			  debug nref
			  
-- 			when ((qname =~ "(do)*(Trace)" :: Bool) && (@kind.self == VirtKind_BeginBody)) $ do
-- 			  str <- declString ("test!!!")
-- 			  l <- freshLabel
-- 			  callTrace str
-- 			  label l
 

  inst.inj1 : InjRoot
  inst.inj1 = @loc.runInject $ do
		    let (classRef, methodRef) = case ctxParents @loc.ctxInfo of
						  CtxParentsCons (CtxTrait (CtxObjClass cls) 
								 (CtxObjMethod meth) 
								 _) CtxParentsNil -> (cls, meth)
						  CtxParentsNil -> (Ref (-1), Ref (-1))
		    let (pack, cls) = case classRef of
					Ref (-1) -> (Nothing, Nothing)
					_ -> let qname = show $ toQName @lhs.tbls $ clName $ lookupClass classRef @lhs.tbls 
						 (pname', cname') = break (':'==) qname 
						 (pname, cname) = if null cname' 
								  then ("", pname') -- swap package and class names
								  else (pname', tail cname')
					     in (Just pname, Just cname)
		    let meth = case methodRef of
				 Ref (-1) -> Nothing
				 _ -> case sigName $ lookupMethod methodRef @lhs.tbls of
					Just strRef -> Just $ lookupString strRef @lhs.tbls
					Nothing -> Nothing
		    let ctxInstr = CtxInstr pack cls meth
		    when (matchInstrPat ctxInstr defMethodInstrPat) $ do		
		      debug (pack, cls, meth)

-- Using this instrumentation we can istert log function call at the beging body of all constructors.
-- Also we can make given instrumentation more selective using patterns or explicitly passing list of classes (packages)
-- we are interested in.
--  inst.inj2: InjRoot
--  inj.inj2 = @loc.runInject $ do
                    
{
type Pattern = String					 
-- type Pattern = RegexMaker Regex CompOption ExecOption

-- We can also use as the possible criterions for MethodInstrCons: contructor, trait qualifiers such as public, private, protected an so on 
data MethodInstrPat = MethodInstrPat { instrPackages :: Maybe [Pattern]
				     , instrClasses  :: Maybe [Pattern]
				     , instrMethods  :: Maybe [Pattern]
				     }  
					 
defMethodInstrPat :: MethodInstrPat
defMethodInstrPat = MethodInstrPat { instrPackages = Nothing
				   , instrClasses  = Nothing 
				   , instrMethods  = Nothing 
				   }
				   
data CtxInstr = CtxInstr { packName :: Maybe String
			 , clsName  :: Maybe String
			 , methName :: Maybe String
			 }
			 
matchInstrPat :: CtxInstr -> MethodInstrPat -> Bool
matchInstrPat (CtxInstr pn cn mn) (MethodInstrPat ppn pcn pmn) = and $ map (\(t, ps) -> matchP t ps) matchingList
  where
    matchingList :: [(Maybe String, Maybe [Pattern])]
    matchingList = [ (pn, ppn)
		   , (cn, pcn)
		   , (mn, pmn)
		   ]
    
    matchP :: Maybe String -> Maybe [Pattern] -> Bool
    matchP v ps = case v of
		     Just v' -> case ps of
				  Just ps' -> and $ map (\pat -> v' =~ pat :: Bool) ps' 
				  Nothing  -> True
		     Nothing -> case ps of
				  Just ps' -> False
				  Nothing -> False
				  	  
}