MODULE {GenSymLib} {generateSymbolLibrary} {}

--
-- With this module, a .swc library can be generated from an .swf.
-- This is unfortunately not a trivial process. The reason is that the .swf may
-- contain classes that were statically linked into the .swf from .swc libraries
-- in the environment. A .swc file, however, may not have duplicate definitions.
--
-- Therefore, to generate a symbol library, a TypeInfo map must be passed,
-- (which can be loaded with --import-env=...), which contains information about the
-- classes that are defined in .swc libraries in the environment.
--
-- Also, there may be resource files (typically, translations of different
-- languages) present in the .swf. These again may only be defined once in a given
-- environment. Since such files can apparently both be present as statically
-- compiled class, or as a file in the .swc, the decision made here is not to
-- generate symbols for types that contain a dollar in the path. It appears that such
-- classes are these language classes.
-- (it is not clear if this is fully correct, but it seems to work in practice)
--

INCLUDE "ByteCodeAst.ag"
INCLUDE "DistSymbolTables.ag"

imports
{
import ByteCode
import Data.Word
import Data.ByteString.Lazy(ByteString)
import qualified Data.ByteString.Lazy as L
import ByteCodeSupport
import PrettyCode
import Codec.Archive.Zip
import ProgInfo
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Map(Map)
import qualified Data.Map as Map
import Data.Monoid
import Text.HTML.Chunks
import Templates
import Data.ByteString.Lazy(ByteString)
import qualified Data.ByteString.Lazy as B
import Codec.Binary.UTF8.String
import Debug.Trace
import Data.List
import ParamAnalysis
}

WRAPPER SwfFile

{
type DefUseMp = Map String ([String],[String])

generateSymbolLibrary :: TypeInfo -> FilePath -> [SymbolTables] -> SwfFile -> IO ()
generateSymbolLibrary envTypes path tbls swf =
  let (swf', scripts)  = toSymLib tbls swf
      bytesIn  = ppSwf swf'
      bytesOut = toSwc envTypes scripts bytesIn
  in L.writeFile path bytesOut

toSymLib :: [SymbolTables] -> SwfFile -> (SwfFile, DefUseMp)
toSymLib tbls m = (out, scripts) where
  inh = Inh_SwfFile { tbls_Inh_SwfFile = tbls }
  sem = sem_SwfFile m
  syn = wrap_SwfFile sem inh
  out = output_Syn_SwfFile syn
  scripts = scripts_Syn_SwfFile syn

toSwc :: TypeInfo -> DefUseMp -> ByteString -> ByteString
toSwc envTypes scripts swf = fromArchive arch where
  arch    = foldr addEntryToArchive emptyArchive entries
  entries = [ catalog, library ]
  catalog = toEntry "catalog.xml" time meta
  library = toEntry "library.swf" time swf
  meta    = B.pack $ encode $ genCatalog envTypes scripts
  time    = 1306755841  -- some time in the past

genCatalog :: TypeInfo -> DefUseMp -> String
genCatalog envTypes scripts = output where
  output = format $ Chunk_catalog defs
  defs   = concat [ format $ Chunk_script nm (genDefs new) (genDeps deps)
                  | (nm,(defs,deps)) <- Map.assocs scripts
                  , let new = filter isExportable defs
                  ]
  genDefs = concatMap (format . Chunk_catalogDef)
  genDeps = concatMap (format . Chunk_catalogDep)
  alreadyDefined = Set.map qnameToKey $ allTypes envTypes
  isExportable def = not (Set.member def alreadyDefined || '$' `elem` def)
}

--
-- Obtain all classes defined by the program
--

ATTR SwfFile Tags Tag [ | | scripts USE {`mappend`} {mempty} : DefUseMp ]

SEM Tag | Abc
  loc.str     = decode $ B.unpack @name
  loc.allUses = @file.uses `Set.difference` @file.defines
  lhs.scripts = Map.singleton @loc.str (Set.toList @file.defines, Set.toList @loc.allUses)

ATTR AbcFile InstanceInfos InstanceInfo [ | | defines USE {`mappend`} {mempty} : {Set String} ]
SEM InstanceInfo | Info
  loc.mbStr   = toExternalString @lhs.tbls (Ref @name)
  lhs.defines = maybe Set.empty Set.singleton @loc.mbStr

--
-- Find out which types are used in the program
--

ATTR AbcFile InstanceInfos InstanceInfo Interfaces MethodInfos MethodInfo ParamTypes
     ClassInfos ClassInfo ScriptInfos ScriptInfo BodyInfos BodyInfo Traits Trait TraitData
  [ | | uses USE {`mappend`} {mempty} : {Set String} ]

SEM InstanceInfo | Info
  +uses = addName @lhs.tbls @super

SEM Interfaces | Cons
  +uses = addName @lhs.tbls @hd

SEM MethodInfo | Info
  +uses = addName @lhs.tbls @return

SEM ParamTypes | Cons
  +uses = addName @lhs.tbls @hd

SEM TraitData | Slot Const
  +uses = addName @lhs.tbls @tp

{
addName :: SymbolTables -> Word32 -> Set String -> Set String
addName _ 0 = id
addName tbls nm
  = case toExternalString tbls (Ref nm) of
      Nothing  -> id
      Just str -> Set.insert str

toExternalString :: SymbolTables -> NameRef -> Maybe String
toExternalString tbls nmRef = mbStr where
  nm    = lookupName nmRef tbls
  nsRef = case nmQual nm of
            QualNs r  -> r
            QualNss s -> case nsSpaces $ lookupNameset s tbls of
              [r]     -> r
              _       -> trace "toExternalString: strange namespace type encountered" (Ref 0)
            _         -> Ref 0
  ns    = lookupNamespace nsRef tbls
  isExported = case nsKind ns of
                 NamespaceKind_General  -> True
                 NamespaceKind_Package  -> True
                 NamespaceKind_Explicit -> True
                 _                      -> False
  str   = nameToKey1 tbls nmRef
  mbStr | isExported = Just str
        | otherwise  = Nothing
}


--
-- Strip non-essential information from the program
--

ATTR AllSwf [ | | output : SELF ]

-- Keep only essential tags
ATTR Tag [ | | essential : Bool ]
SEM Tag
  | Abc FileAttributes End
      lhs.essential = True
  | Opaque
      lhs.essential = False

SEM Tags | Cons
  lhs.output = if @hd.essential
               then @hd.output : @tl.output
               else @tl.output

-- Strip exception handlers
SEM Exceptions | Cons
  lhs.output = []

-- Strip method bodies
SEM InstructionsTop | Top
  lhs.output = InstructionsTop_Top emptyBody

{
emptyBody :: Instructions   -- represents the empty method body
emptyBody
  = [ LabInstruction_Instr 0 $ Instruction_Virtual 0 VirtKind_BeginBody
    , LabInstruction_Instr 1 $ Instruction_Virtual 1 $ VirtKind_BeginBlock False
    , LabInstruction_Instr 2 $ Instruction_Virtual 2 VirtKind_EndBlock
    , LabInstruction_Instr 3 $ Instruction_Virtual 3 VirtKind_EndBody
    , LabInstruction_Instr 4 $ Instruction_ReturnVoid
    , LabInstruction_Instr 5 $ Instruction_Virtual 5 VirtKind_Terminator
    ]
}