MODULE {PrettyCode} {ppSwf,ppAbc} {} optpragmas { {-# LANGUAGE TypeSynonymInstances #-} } INCLUDE "ByteCodeAst.ag" INCLUDE "PrettyInstr.ag" imports { import Codec.Compression.Zlib import Data.Binary.Builder import Data.Binary.IEEE754 import qualified Data.Binary.Put as P import Data.Bits import Data.ByteString.Lazy(ByteString) import qualified Data.ByteString.Lazy as B import Data.Word import Data.Monoid import ByteCode } WRAPPER SwfFile WRAPPER AbcFile { ppSwf :: SwfFile -> ByteString ppSwf m = str where inh = Inh_SwfFile {} sem = sem_SwfFile m syn = wrap_SwfFile sem inh out = output_Syn_SwfFile syn str = toLazyByteString out ppAbc :: AbcFile -> ByteString ppAbc m = str where inh = Inh_AbcFile {} sem = sem_AbcFile m syn = wrap_AbcFile sem inh out = output_Syn_AbcFile syn str = toLazyByteString out } { class ToBuilder a where toBuilder :: a -> Builder instance ToBuilder ByteString where toBuilder = fromLazyByteString instance ToBuilder Builder where toBuilder = id instance ToBuilder Word8 where toBuilder = singleton infixr 3 ## (##) :: (ToBuilder a, ToBuilder b) => a -> b -> Builder a ## b = toBuilder a `append` toBuilder b u8 :: Word8 -> Builder u8 = singleton . fromIntegral w32 :: Word32 -> Builder w32 = putWord32le d64 :: Double -> Builder d64 = toBuilder . P.runPut . putFloat64le u16 :: Word16 -> Builder u16 = putWord16le s24 :: Word32 -> Builder s24 w = u8 w1 ## u8 w2 ## u8 w3 where w1 = fromIntegral (w .&. 0xFF) w2 = fromIntegral (shiftR w 8 .&. 0xFF) w3 = fromIntegral (shiftR w 16 .&. 0xFF) -- Note: ignoring here the exact size. u30 :: Word32 -> Builder u30 = v32 False s32 :: Word32 -> Builder s32 = v32 True u32 :: Word32 -> Builder u32 = v32 False -- Rather complicated due to compression of negative numbers. v32 :: Bool -> Word32 -> Builder v32 isSigned w | isSigned && w `testBit` 31 = negative | otherwise = positive where part w' = let r = shiftR w' 7 -- drop seven bits, the residual bits form the remainder v = w' .&. 0x7F -- take the first seven bits ps | r > 0 = part r | otherwise = [] in fromIntegral v : ps ws = part w -- non-empty sequence of 7 bits mark [x] = [x] -- last byte unchanged mark (x:xs) = setBit x 7 : mark xs -- mark 7th bit of all but the last byte positive = build (mark ws) -- render to a sequence of bytes negative = let -- given a reversed byte sequence, strips off those bytes with the 7 bits set strip [x] = [x] -- least significant byte unchanged strip (x:y:xs) | x == 0x7F && y `testBit` 6 = strip (y:xs) -- only if the next byte has the sign-bit set | otherwise = x : y : xs wr = reverse ws wr' = (extend $ head wr) : tail wr -- sign extend the first byte extend = let extend' n x | not (x `testBit` n) = bit n .|. extend' (n-1) x | otherwise = x in extend' 6 -- a n == 0 situation cannot happen: number is negative, there must be a sign bit ws' = mark . reverse . strip $ wr' in build ws' build = foldr (\x r -> u8 x ## r) empty u30size :: Int -> Builder u30size = u30 . fromIntegral nullString :: ByteString -> Builder nullString s = s ## u8 0 } { newtype BitBuilder = BitBuilder ([Bool] -> [Bool]) instance Monoid BitBuilder where mempty = BitBuilder id mappend (BitBuilder f) (BitBuilder g) = BitBuilder (f . g) infixr 3 ### (###) :: BitBuilder -> BitBuilder -> BitBuilder (###) = mappend -- | To put a number in, put the most significant bits first. putBits :: [Bool] -> BitBuilder putBits xs = BitBuilder (xs ++) putBit :: Bool -> BitBuilder putBit = putBits . return putWord :: Word32 -> Int -> BitBuilder putWord w n | n <= 0 = error "putWord: n <= 0" | otherwise = putBits [ testBit w (n-i) | i <- [1 .. n] ] padded :: BitBuilder -> Builder padded (BitBuilder f) = builder where bits = f [] len = length bits pad = (8 - (len `rem` 8)) `mod` 8 bits' = bits ++ replicate pad False bytes = map b2w8 $ split bits' builder = foldr (\b r -> u8 b ## r) mempty bytes split [] = [] split xs = let (ys,zs) = splitAt 8 xs in ys : split zs b2w8 = foldl (\r b -> shiftL r 1 .|. (if b then 1 else 0)) 0 } -- Common attributes SET NoOutput = Rect TagKind AbcFlags AbcFlag ATTR (AllSwf - NoOutput) [ | | output USE {##} {mempty} : Builder ] ATTR Rect [ | | output : BitBuilder ] ATTR TagKind NamespaceKind MultinameKind ValueKind [ | | kind : SELF ] ATTR AbcFlags AbcFlag [ | | flags USE {.|.} {0} : Word32 ] -- Pretty printers SEM SwfFile | File lhs.output = @loc.head ## u8 @version ## w32 @loc.length ## @loc.content loc.head = u8 (if @compressed then 0x43 else 0x46) ## u8 0x57 ## u8 0x53 loc.length = fromIntegral (8 + B.length @loc.bodyStr) loc.content = if @compressed then compressWith defaultCompressParams { compressLevel = bestCompression } @loc.bodyStr else @loc.bodyStr loc.bodyStr = toLazyByteString @loc.body loc.body = padded @size.output ## u16 @rate ## u16 @count ## @tags.output SEM Rect | Rect lhs.output = putWord (fromIntegral @bits) 5 ### putWord @xMin @bits ### putWord @yMin @bits ### putWord @xMax @bits ### putWord @yMax @bits SEM Tag | Abc inst.body : Tag -- desugar to an Opaque inst.body = Tag_Opaque TagKind_DoABC @loc.length @loc.content loc.file = w32 @flags.flags ## nullString @name ## @file.output loc.content = toLazyByteString @loc.file loc.length = fromIntegral $ B.length @loc.content lhs.output = @body.output | FileAttributes inst.body : Tag -- desugar to an Opaque inst.body = Tag_Opaque TagKind_FileAttributes @loc.length @loc.content loc.data = padded ( putWord 0 1 ### putBit @useDirectBlit ### putBit @useGPU ### putBit @hasMetaData ### putBit @hasAS3 ### putWord 0 2 ### putBit @useNetwork ### putWord 0 24) loc.content = toLazyByteString @loc.data loc.length = fromIntegral $ B.length @loc.content | Opaque loc.len' = min @length 0x3f loc.code = fromTagKind @kind.kind loc.key = shiftL @loc.code 6 .|. (fromIntegral @loc.len') loc.header = u16 @loc.key ## if @length >= 0x3F then w32 @length else empty lhs.output = @loc.header ## @body | End lhs.output = u16 0 SEM AbcFlag | LazyInit lhs.flags = 1 { fromTagKind :: TagKind -> Word16 fromTagKind k = case k of TagKind_End -> 0 TagKind_ShowFrame -> 1 TagKind_DefineShape -> 2 TagKind_PlaceObject -> 4 TagKind_RemoveObject -> 5 TagKind_DefineBits -> 6 TagKind_DefineButton -> 7 TagKind_JPEGTables -> 8 TagKind_SetBackgroundColor -> 9 TagKind_DefineFont -> 10 TagKind_DefineText -> 11 TagKind_DoAction -> 12 TagKind_DefineFontInfo -> 13 TagKind_DefineSound -> 14 TagKind_StartSound -> 15 TagKind_DefineButtonSound -> 17 TagKind_SoundStreamHead -> 18 TagKind_SoundStreamBlock -> 19 TagKind_DefineBitsLossless -> 20 TagKind_DefineBitsJPEG2 -> 21 TagKind_DefineShape2 -> 22 TagKind_DefineButtonCxform -> 23 TagKind_Protect -> 24 TagKind_PlaceObject2 -> 26 TagKind_RemoveObject2 -> 28 TagKind_DefineShape3 -> 32 TagKind_DefineText2 -> 33 TagKind_DefineButton2 -> 34 TagKind_DefineBitsJPEG3 -> 35 TagKind_DefineBitsLossless2 -> 36 TagKind_DefineEditText -> 37 TagKind_DefineSprite -> 39 TagKind_FrameLabel -> 43 TagKind_SoundStreamHead2 -> 45 TagKind_DefineMorphShape -> 46 TagKind_DefineFont2 -> 48 TagKind_ExportAssets -> 56 TagKind_ImportAssets -> 57 TagKind_EnableDebugger -> 58 TagKind_DoInitAction -> 59 TagKind_DefineVideoStream -> 60 TagKind_VideoFrame -> 61 TagKind_DefineFontInfo2 -> 62 TagKind_EnableDebugger2 -> 64 TagKind_ScriptLimits -> 65 TagKind_SetTabIndex -> 66 TagKind_FileAttributes -> 69 TagKind_PlaceObject3 -> 70 TagKind_ImportAssets2 -> 71 TagKind_DefineFontAlignZones -> 73 TagKind_CSMTextSettings -> 74 TagKind_DefineFont3 -> 75 TagKind_SymbolClass -> 76 TagKind_Metadata -> 77 TagKind_DefineScalingGrid -> 78 TagKind_DoABC -> 82 TagKind_DefineShape4 -> 83 TagKind_DefineMorphShape2 -> 84 TagKind_DefineSceneAndFrameLabelData -> 86 TagKind_DefineBinaryData -> 87 TagKind_DefineFontName -> 88 TagKind_StartSound2 -> 89 TagKind_DefineBitsJPEG4 -> 90 TagKind_DefineFont4 -> 91 TagKind_Other c -> c } ATTR MethodInfos MetaInfos InstanceInfos ClassInfos ScriptInfos BodyInfos PoolInts PoolUInts PoolDoubles PoolStrings NamespaceInfos SetInfos NamespaceNames MultinameInfos Optionals ParamNames ParamTypes MetaItems Traits Interfaces TraitMeta Exceptions [ | | count USE {+} {0} : Int ] SEM MethodInfos | Cons +count = (+1) SEM MetaInfos | Cons +count = (+1) SEM InstanceInfos | Cons +count = (+1) SEM ClassInfos | Cons +count = (+1) SEM ScriptInfos | Cons +count = (+1) SEM BodyInfos | Cons +count = (+1) SEM PoolInts | Cons +count = (+1) SEM PoolUInts | Cons +count = (+1) SEM PoolDoubles | Cons +count = (+1) SEM PoolStrings | Cons +count = (+1) SEM NamespaceInfos | Cons +count = (+1) SEM SetInfos | Cons +count = (+1) SEM NamespaceNames | Cons +count = (+1) SEM MultinameInfos | Cons +count = (+1) SEM Optionals | Cons +count = (+1) SEM ParamNames | Cons +count = (+1) SEM ParamTypes | Cons +count = (+1) SEM MetaItems | Cons +count = (+1) SEM Traits | Cons +count = (+1) SEM Interfaces | Cons +count = (+1) SEM TraitMeta | Cons +count = (+1) SEM Exceptions | Cons +count = (+1) SEM AbcFile | File lhs.output = u16 @minorVersion ## u16 @majorVersion ## @constantPool.output ## u30size @methods.count ## @methods.output ## u30size @metadatas.count ## @metadatas.output ## u30size @instances.count ## @instances.output ## @classes.output ## u30size @scripts.count ## @scripts.output ## u30size @bodies.count ## @bodies.output SEM PoolInfo | Info lhs.output = u30size1 @integers.count ## @integers.output ## u30size1 @uintegers.count ## @uintegers.output ## u30size1 @doubles.count ## @doubles.output ## u30size1 @strings.count ## @strings.output ## u30size1 @namespaces.count ## @namespaces.output ## u30size1 @namesets.count ## @namesets.output ## u30size1 @multinames.count ## @multinames.output { u30size1 n = u30size (if n == 0 then 0 else n+1) } SEM PoolInts | Cons lhs.output = s32 @hd ## @tl.output SEM PoolUInts | Cons lhs.output = u32 @hd ## @tl.output SEM PoolDoubles | Cons lhs.output = d64 @hd ## @tl.output SEM PoolStrings | Cons loc.blen = fromIntegral $ B.length @hd lhs.output = u30size @loc.blen ## @hd ## @tl.output SEM NamespaceInfo | Info lhs.output = u8 (fromNamespaceKind @kind.kind) ## u30 @name { fromNamespaceKind k = case k of NamespaceKind_General -> 0x08 NamespaceKind_Package -> 0x16 NamespaceKind_Internal -> 0x17 NamespaceKind_Protected -> 0x18 NamespaceKind_Explicit -> 0x19 NamespaceKind_Static -> 0x1A NamespaceKind_Private -> 0x05 } SEM SetInfo | Info lhs.output = u30size @names.count ## @names.output SEM NamespaceNames | Cons lhs.output = u30 @hd ## @tl.output SEM MultinameInfo | QName lhs.output = u8 0x07 ## u30 @namespace ## u30 @name | QNameA lhs.output = u8 0x0D ## u30 @namespace ## u30 @name | RTQName lhs.output = u8 0x0F ## u30 @name | RTQNameA lhs.output = u8 0x10 ## u30 @name | RTQNameL lhs.output = u8 0x11 | RTQNameLA lhs.output = u8 0x12 | Multiname lhs.output = u8 0x09 ## u30 @name ## u30 @set | MultinameA lhs.output = u8 0x0E ## u30 @name ## u30 @set | MultinameL lhs.output = u8 0x1B ## u30 @set | MultinameLA lhs.output = u8 0x1C ## u30 @set | Generic lhs.output = u8 0x1D ## u30 @name ## u30size @params.count ## @params.output SEM ParamNames | Cons lhs.output = u30 @hd ## @tl.output ATTR MethodFlags MethodFlag [ | | flags : SELF ] SEM MethodInfo | Info lhs.output = u30size @params.count ## u30 @return ## @params.output ## u30 @name ## u8 (mergeMethodFlags @flags.flags) ## @loc.options ## @loc.names loc.options = if MethodFlag_HasOptionals `elem` @flags.flags then u30size @options.count ## @options.output else empty loc.names = if MethodFlag_HasParamNames `elem` @flags.flags then @names.output else empty { mergeMethodFlags :: MethodFlags -> Word8 mergeMethodFlags = foldr (.|.) 0 . map fromFlag where fromFlag fl = case fl of MethodFlag_NeedArgs -> 0x01 MethodFlag_NeedAct -> 0x02 MethodFlag_NeedRest -> 0x04 MethodFlag_HasOptionals -> 0x08 MethodFlag_SetDXNS -> 0x40 MethodFlag_HasParamNames -> 0x80 } SEM ParamTypes | Cons lhs.output = u30 @hd ## @tl.output SEM Optional | Detail lhs.output = u32 @val ## u8 (fromValueKind @kind.kind) { fromValueKind :: ValueKind -> Word8 fromValueKind k = case k of ValueKind_Int -> 0x03 ValueKind_UInt -> 0x04 ValueKind_Double -> 0x06 ValueKind_Utf8 -> 0x01 ValueKind_True -> 0x0B ValueKind_False -> 0x0A ValueKind_Null -> 0x0C ValueKind_Undefined -> 0x00 ValueKind_Namespace -> 0x08 ValueKind_Package -> 0x16 ValueKind_Internal -> 0x17 ValueKind_Protected -> 0x18 ValueKind_Explicit -> 0x19 ValueKind_Static -> 0x1A ValueKind_Private -> 0x05 } SEM MetaInfo | Info lhs.output = u30 @name ## u30size @items.count ## @items.output SEM MetaItem | Item lhs.output = u30 @key ## u30 @value ATTR InstanceFlags InstanceFlag [ | | flags : SELF ] SEM InstanceInfo | Info lhs.output = u30 @name ## u30 @super ## u8 (mergeInstanceFlags @flags.flags) ## @loc.prot ## u30size @interfaces.count ## @interfaces.output ## u30 @constructor ## u30size @traits.count ## @traits.output loc.prot = if InstanceFlag_ClassProtected `elem` @flags.flags then u30 @protectedNs else empty { mergeInstanceFlags :: InstanceFlags -> Word8 mergeInstanceFlags = foldr (.|.) 0 . map fromFlag where fromFlag fl = case fl of InstanceFlag_ClassSealed -> 0x01 InstanceFlag_ClassFinal -> 0x02 InstanceFlag_ClassInterface -> 0x04 InstanceFlag_ClassProtected -> 0x08 } SEM Interfaces | Cons lhs.output = u30 @hd ## @tl.output SEM TraitMeta | Cons lhs.output = u30 @hd ## @tl.output SEM Trait | Trait lhs.output = u30 @name ## @data.output ## @loc.optMet loc.optMet = if TraitAttr_Metadata `elem` @attrs.flags then u30size @meta.count ## @meta.output else empty data.flags = mergeTraitFlags @attrs.flags ATTR TraitAttrs TraitAttr [ | | flags : SELF ] { mergeTraitFlags :: TraitAttrs -> Word8 mergeTraitFlags = foldr (.|.) 0 . map fromFlag where fromFlag fl = case fl of TraitAttr_Final -> 0x01 TraitAttr_Override -> 0x02 TraitAttr_Metadata -> 0x04 } ATTR TraitData [ flags : Word8 | | ] SEM TraitData | Slot loc.tp = 0 | Method loc.tp = 1 | Getter loc.tp = 2 | Setter loc.tp = 3 | Class loc.tp = 4 | Function loc.tp = 5 | Const loc.tp = 6 SEM TraitData | * lhs.output = u8 (shiftL @lhs.flags 4 .|. @loc.tp) ## @loc.body SEM TraitData | Slot Const loc.body = u30 @slotId ## u30 @tp ## u30 @vindex ## @loc.kind loc.kind = if @vindex > 0 then u8 (fromValueKind @vkind.kind) else empty | Method Getter Setter Function loc.body = u30 @dispId ## u30 @method | Class loc.body = u30 @slotId ## u30 @class SEM ClassInfo | Info lhs.output = u30 @con ## u30size @traits.count ## @traits.output SEM ScriptInfo | Info lhs.output = u30 @method ## u30size @traits.count ## @traits.output SEM BodyInfo | Info lhs.output = u30 @method ## u30 @maxStack ## u30 @localCount ## u30 @initScopeDepth ## u30 @maxScopeDepth ## u30size @loc.length ## @loc.content ## u30size @exceptions.count ## @exceptions.output ## u30size @traits.count ## @traits.output loc.content = toLazyByteString @instructions.output loc.length = fromIntegral $ B.length @loc.content SEM Instruction | Location lhs.output = mempty SEM Exception | Info lhs.output = u30 @from ## u30 @to ## u30 @target ## u30 @tp ## u30 @name