├── examples ├── .gitignore ├── gnash │ ├── test.swf │ ├── green.swf │ ├── lynch.swf │ ├── money3.swf │ ├── player.swf │ ├── slider.swf │ ├── sound1.swf │ ├── car_smash.swf │ ├── counter.swf │ ├── gravity.swf │ ├── offspring.swf │ ├── sr2_title.swf │ ├── subshapes.swf │ ├── text-test.swf │ ├── vnc2swf.swf │ ├── zoomhenge.swf │ ├── dlist_test1.swf │ ├── event-test1.swf │ ├── test_frame1.swf │ ├── test_frame2.swf │ ├── test_string.swf │ ├── text-test2.swf │ ├── text_sizes.swf │ ├── TestFunction2.swf │ ├── clip_as_button.swf │ ├── gradient-tests.swf │ ├── input-fields.swf │ ├── movieclip_test.swf │ ├── shared-fonts.swf │ ├── test_function2.swf │ ├── test_goto_play.swf │ ├── test_goto_stop.swf │ ├── test_rotation.swf │ ├── test_rotation2.swf │ ├── GotoAndPlayTest.swf │ ├── clip_as_button2.swf │ ├── gravity-embedded.swf │ ├── test_basic_types.swf │ ├── test_forin_array.swf │ ├── test_goto_frame.swf │ ├── text_formatting.swf │ ├── display_list_test.swf │ ├── gotoFrameOnKeyEvent.swf │ ├── test_action_order.swf │ ├── test_action_order2.swf │ ├── test_clipping_layer.swf │ ├── test_rotation_shear.swf │ ├── test_shape_tweening.swf │ ├── test_undefined_v6.swf │ ├── test_undefined_v7.swf │ ├── test_button_functions.swf │ ├── test_colour_tweening.swf │ ├── test_gradients_alpha.swf │ ├── test_long_static_text.swf │ ├── test_shape_tweening-2.swf │ ├── extended_clipping_test_1.swf │ ├── test_gradient_tweening.swf │ ├── test_gradients_no_alpha.swf │ ├── visible_and_transparency.swf │ ├── test_cascaded_clipbuttons.swf │ └── LICENSE ├── spec │ └── example.swf └── flash-gordon │ ├── blue.swf │ ├── trip.swf │ └── tiger.swf ├── Setup.hs ├── generate.sh ├── Data ├── SWF.hs └── SWF │ └── Internal │ ├── Utilities.hs │ └── Binary.hs ├── .gitignore ├── .ghci ├── tests ├── VanillaRect.hs ├── Tests.hs ├── Primitives.hs ├── Roundtripping.hs ├── TestUtilities.hs ├── SpecificationExample.hs └── DefineShapeAlignment.hs ├── Args.hs ├── hswf.cabal ├── LICENSE ├── Main.hs └── generator ├── Cleaner.hs └── Main.hs /examples/.gitignore: -------------------------------------------------------------------------------- 1 | commercial/ 2 | 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain -------------------------------------------------------------------------------- /examples/gnash/test.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test.swf -------------------------------------------------------------------------------- /generate.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | runghc generator/Main.hs Data/SWF/Format.in.lhs > Data/SWF/Format.lhs 3 | -------------------------------------------------------------------------------- /examples/gnash/green.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/green.swf -------------------------------------------------------------------------------- /examples/gnash/lynch.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/lynch.swf -------------------------------------------------------------------------------- /examples/gnash/money3.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/money3.swf -------------------------------------------------------------------------------- /examples/gnash/player.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/player.swf -------------------------------------------------------------------------------- /examples/gnash/slider.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/slider.swf -------------------------------------------------------------------------------- /examples/gnash/sound1.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/sound1.swf -------------------------------------------------------------------------------- /examples/spec/example.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/spec/example.swf -------------------------------------------------------------------------------- /Data/SWF.hs: -------------------------------------------------------------------------------- 1 | module Data.SWF ( 2 | module Data.SWF.Format 3 | ) where 4 | 5 | import Data.SWF.Format 6 | -------------------------------------------------------------------------------- /examples/gnash/car_smash.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/car_smash.swf -------------------------------------------------------------------------------- /examples/gnash/counter.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/counter.swf -------------------------------------------------------------------------------- /examples/gnash/gravity.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/gravity.swf -------------------------------------------------------------------------------- /examples/gnash/offspring.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/offspring.swf -------------------------------------------------------------------------------- /examples/gnash/sr2_title.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/sr2_title.swf -------------------------------------------------------------------------------- /examples/gnash/subshapes.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/subshapes.swf -------------------------------------------------------------------------------- /examples/gnash/text-test.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/text-test.swf -------------------------------------------------------------------------------- /examples/gnash/vnc2swf.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/vnc2swf.swf -------------------------------------------------------------------------------- /examples/gnash/zoomhenge.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/zoomhenge.swf -------------------------------------------------------------------------------- /examples/flash-gordon/blue.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/flash-gordon/blue.swf -------------------------------------------------------------------------------- /examples/flash-gordon/trip.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/flash-gordon/trip.swf -------------------------------------------------------------------------------- /examples/gnash/dlist_test1.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/dlist_test1.swf -------------------------------------------------------------------------------- /examples/gnash/event-test1.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/event-test1.swf -------------------------------------------------------------------------------- /examples/gnash/test_frame1.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_frame1.swf -------------------------------------------------------------------------------- /examples/gnash/test_frame2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_frame2.swf -------------------------------------------------------------------------------- /examples/gnash/test_string.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_string.swf -------------------------------------------------------------------------------- /examples/gnash/text-test2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/text-test2.swf -------------------------------------------------------------------------------- /examples/gnash/text_sizes.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/text_sizes.swf -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Build artifacts 2 | dist/ 3 | *.hi 4 | *.o 5 | 6 | # Operating system rubbish 7 | .DS_Store 8 | Thumbs.db 9 | -------------------------------------------------------------------------------- /examples/flash-gordon/tiger.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/flash-gordon/tiger.swf -------------------------------------------------------------------------------- /examples/gnash/TestFunction2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/TestFunction2.swf -------------------------------------------------------------------------------- /examples/gnash/clip_as_button.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/clip_as_button.swf -------------------------------------------------------------------------------- /examples/gnash/gradient-tests.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/gradient-tests.swf -------------------------------------------------------------------------------- /examples/gnash/input-fields.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/input-fields.swf -------------------------------------------------------------------------------- /examples/gnash/movieclip_test.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/movieclip_test.swf -------------------------------------------------------------------------------- /examples/gnash/shared-fonts.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/shared-fonts.swf -------------------------------------------------------------------------------- /examples/gnash/test_function2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_function2.swf -------------------------------------------------------------------------------- /examples/gnash/test_goto_play.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_goto_play.swf -------------------------------------------------------------------------------- /examples/gnash/test_goto_stop.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_goto_stop.swf -------------------------------------------------------------------------------- /examples/gnash/test_rotation.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_rotation.swf -------------------------------------------------------------------------------- /examples/gnash/test_rotation2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_rotation2.swf -------------------------------------------------------------------------------- /examples/gnash/GotoAndPlayTest.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/GotoAndPlayTest.swf -------------------------------------------------------------------------------- /examples/gnash/clip_as_button2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/clip_as_button2.swf -------------------------------------------------------------------------------- /examples/gnash/gravity-embedded.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/gravity-embedded.swf -------------------------------------------------------------------------------- /examples/gnash/test_basic_types.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_basic_types.swf -------------------------------------------------------------------------------- /examples/gnash/test_forin_array.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_forin_array.swf -------------------------------------------------------------------------------- /examples/gnash/test_goto_frame.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_goto_frame.swf -------------------------------------------------------------------------------- /examples/gnash/text_formatting.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/text_formatting.swf -------------------------------------------------------------------------------- /examples/gnash/display_list_test.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/display_list_test.swf -------------------------------------------------------------------------------- /examples/gnash/gotoFrameOnKeyEvent.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/gotoFrameOnKeyEvent.swf -------------------------------------------------------------------------------- /examples/gnash/test_action_order.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_action_order.swf -------------------------------------------------------------------------------- /examples/gnash/test_action_order2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_action_order2.swf -------------------------------------------------------------------------------- /examples/gnash/test_clipping_layer.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_clipping_layer.swf -------------------------------------------------------------------------------- /examples/gnash/test_rotation_shear.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_rotation_shear.swf -------------------------------------------------------------------------------- /examples/gnash/test_shape_tweening.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_shape_tweening.swf -------------------------------------------------------------------------------- /examples/gnash/test_undefined_v6.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_undefined_v6.swf -------------------------------------------------------------------------------- /examples/gnash/test_undefined_v7.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_undefined_v7.swf -------------------------------------------------------------------------------- /examples/gnash/test_button_functions.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_button_functions.swf -------------------------------------------------------------------------------- /examples/gnash/test_colour_tweening.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_colour_tweening.swf -------------------------------------------------------------------------------- /examples/gnash/test_gradients_alpha.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_gradients_alpha.swf -------------------------------------------------------------------------------- /examples/gnash/test_long_static_text.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_long_static_text.swf -------------------------------------------------------------------------------- /examples/gnash/test_shape_tweening-2.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_shape_tweening-2.swf -------------------------------------------------------------------------------- /examples/gnash/extended_clipping_test_1.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/extended_clipping_test_1.swf -------------------------------------------------------------------------------- /examples/gnash/test_gradient_tweening.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_gradient_tweening.swf -------------------------------------------------------------------------------- /examples/gnash/test_gradients_no_alpha.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_gradients_no_alpha.swf -------------------------------------------------------------------------------- /examples/gnash/visible_and_transparency.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/visible_and_transparency.swf -------------------------------------------------------------------------------- /examples/gnash/test_cascaded_clipbuttons.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/batterseapower/hswf/master/examples/gnash/test_cascaded_clipbuttons.swf -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -XTupleSections -XRecordWildCards -XDeriveDataTypeable -XGeneralizedNewtypeDeriving -XStandaloneDeriving -XPatternGuards 2 | :set -itests -i. 3 | :set -package QuickCheck-1.2.0.0 4 | :load tests/Tests.hs 5 | -------------------------------------------------------------------------------- /tests/VanillaRect.hs: -------------------------------------------------------------------------------- 1 | module VanillaRect where 2 | 3 | import TestUtilities 4 | 5 | 6 | main = runGet vanilla_rect_bytes getRECT `assertEquals` vanilla_rect 7 | 8 | -- From the specification: tests handling of bitfields and SB values 9 | vanilla_rect_bytes = [ 10 | 0x78, 0x00, 0x05, 0x5F, 0x00, 0x00, 0x0F, 0xA0, 0x00 11 | ] 12 | 13 | vanilla_rect = RECT { rECT_xmin = 0, rECT_xmax = 11000, rECT_ymin = 0, rECT_ymax = 8000 } 14 | -------------------------------------------------------------------------------- /Args.hs: -------------------------------------------------------------------------------- 1 | module Args where 2 | 3 | import System.Console.CmdArgs 4 | 5 | 6 | data HSwf 7 | = Debug { 8 | files :: [FilePath], 9 | incremental :: Bool 10 | } 11 | | Decode { 12 | files :: [FilePath] 13 | } 14 | deriving (Show, Data, Typeable) 15 | 16 | debugMode = mode $ Debug { 17 | files = def &= args & text "Files to read", 18 | incremental = False &= text "Display debug output incrementally" 19 | } 20 | 21 | decodeMode = mode $ Decode { 22 | files = def &= args & text "Files to decode" 23 | } 24 | 25 | getArgs :: IO HSwf 26 | getArgs = cmdArgs "HSwf v0.1, (C) 2010 Max Bolingbroke" [debugMode, decodeMode] -------------------------------------------------------------------------------- /hswf.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: >= 1.2 2 | Build-Type: Simple 3 | Name: hswf 4 | Version: 0.1 5 | Maintainer: Max Bolingbroke 6 | Homepage: http://www.github.com/batterseapower/hswf 7 | License: BSD3 8 | License-File: LICENSE 9 | Author: Max Bolingbroke 10 | Synopsis: A library for SWF reading and writing, aiming for byte-for-byte roundtripping support 11 | Category: Language 12 | 13 | Executable swf 14 | Main-Is: Main.hs 15 | Build-Depends: base >= 4 && < 5, bytestring >= 0.9.1.5 && < 0.10, 16 | zlib >= 0.5.2.0 && < 0.6, binary >= 0.5.0.2 && < 0.6, 17 | cmdargs == 0.1, pretty >= 1.0.1.1 && < 1.1, syb >= 0.1.0.2 && < 0.2, 18 | filepath >= 1.1.0.3 && < 1.2 19 | Extensions: PatternGuards, RecordWildCards, TupleSections, Rank2Types, 20 | DeriveDataTypeable, GeneralizedNewtypeDeriving, ExistentialQuantification 21 | 22 | Ghc-Options: -fwarn-unused-binds -fwarn-unused-imports -fwarn-unused-matches -fwarn-overlapping-patterns -fwarn-unused-do-bind 23 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | import qualified Primitives 2 | import qualified VanillaRect 3 | import qualified DefineShapeAlignment 4 | import qualified Roundtripping 5 | import qualified SpecificationExample 6 | 7 | import Data.SWF.Internal.Utilities 8 | 9 | import Data.Char 10 | import Data.List 11 | 12 | 13 | -- The actual tests: 14 | main :: IO () 15 | main = do 16 | Primitives.main 17 | VanillaRect.main 18 | DefineShapeAlignment.main 19 | Roundtripping.main 20 | SpecificationExample.main 21 | 22 | 23 | -- Useful for constructing new tests: 24 | showHexList :: Integral a => [a] -> String 25 | showHexList xs = "[" ++ intercalate ", " ["0x" ++ padTo 2 '0' (map toUpper $ showHex x "") | x <- xs] ++ "]" 26 | 27 | showListBinary :: Integral a => [a] -> String 28 | showListBinary xs = intercalate " " [padTo 8 '0' (showBinary x "") | x <- xs] 29 | 30 | pretty :: String -> String 31 | pretty = unlines . go 0 "" 32 | where 33 | go lvl line (',':rest) = finish lvl (',' : line) : go lvl "" rest 34 | go lvl line ('{':'}':rest) = go lvl ('}' : '{' : line) rest 35 | go lvl line ('[':']':rest) = go lvl (']' : '[' : line) rest 36 | go lvl line (o:rest) | o `elem` "{[" = finish lvl (o : line) : go (lvl + 2) "" rest 37 | go lvl line (c:rest) | c `elem` "}]" = finish lvl line : go (lvl - 2) [c] rest 38 | go lvl line (x:rest) = go lvl (x : line) rest 39 | go lvl line [] = [finish lvl line] 40 | 41 | finish lvl line = replicate (lvl * 2) ' ' ++ dropWhile isSpace (reverse (dropWhile isSpace line)) 42 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Max Bolingbroke 2006-2007. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Max Bolingbroke nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /tests/Primitives.hs: -------------------------------------------------------------------------------- 1 | module Primitives where 2 | 3 | import TestUtilities 4 | 5 | 6 | main = do 7 | let run getter putter ws x = do 8 | runGet ws getter `assertEquals` x 9 | runPut (putter x) `assertEquals` ws 10 | 11 | run getFIXED putFIXED [0x00, 0x80, 0x07, 0x00] $ FIXED { fIXED_integer = 7, fIXED_decimal = 32768 } -- 7.5 12 | 13 | -- seeeeeeeemmmmmmmmmmmmmmmmmmmmmmm 14 | -- 01111111100000000000000000000000 = 0x7F800000 = +Infinity 15 | run getFLOAT putFLOAT [0x00, 0x00, 0x80, 0x7F] (1/0) 16 | 17 | -- seeeeemmmmmmmmmm 18 | -- 0100000000000000 = 0x4000 = +1.0 * 2^(16 - 16) = 1 19 | -- 0100001000000000 = 0x4200 = +1.5 * 2^(16 - 16) = 1.5 20 | run getFLOAT16 putFLOAT16 [0x00, 0x40] $ floatToFLOAT16 1 21 | run getFLOAT16 putFLOAT16 [0x00, 0x42] $ floatToFLOAT16 1.5 22 | -- 0111110000000000 = 0x7C00 = +Infinity 23 | -- 1111110000000000 = 0xFC00 = -Infinity 24 | run getFLOAT16 putFLOAT16 [0x00, 0x7C] $ floatToFLOAT16 (1/0) 25 | run getFLOAT16 putFLOAT16 [0x00, 0xFC] $ floatToFLOAT16 (-1/0) 26 | -- 0111110000010000 = 0x7C10 = NaN 27 | -- 1111110000010000 = 0xFC10 = NaN 28 | let fLOAT16NaN = floatToFLOAT16 (0/0) 29 | assertNaN x = if isNaN (fLOAT16ToFloat x) then return () else sayNotEqual ["assertNaN"] x fLOAT16NaN 30 | assertNaN $ runGet [0x10, 0x7C] getFLOAT16 31 | assertNaN $ runGet [0x10, 0xFC] getFLOAT16 32 | runPut (putFLOAT16 fLOAT16NaN) `assertEquals` [0xFF, 0x7F] 33 | 34 | run (aligned $ getUB 5) (flushed . putUB 5) [0x78] 15 35 | run (aligned $ getSB 4) (flushed . putSB 4) [0xE0] (-2) 36 | run (aligned $ getSB 7) (flushed . putSB 7) [0x46] 35 37 | run (aligned $ getSB 8) (flushed . putSB 8) [0x46] 70 38 | run (aligned $ getSB 9) (flushed . putSB 9) [0x11, 0x80] 35 39 | -- These two test case were given in the specification with 0x30 instead of 0x60, but: 40 | -- 0x30 0x00 0x00 (19 bits) = 0011 0000 0000 0000 000x xxxx = 98304 (logical value), which doesn't match their result! 41 | -- 196608 (19 bits) = 0110 0000 0000 0000 000x xxxx = 0x60 0x00 0x00 42 | run (aligned $ getSB 19) (flushed . putSB 19) [0x60, 0x00, 0x00] 196608 43 | run (aligned $ getFB 19) (flushed . putFB 19) [0x60, 0x00, 0x00] $ FIXED { fIXED_integer = 3, fIXED_decimal = 0 * 65536 } -- 7.5 44 | -------------------------------------------------------------------------------- /Data/SWF/Internal/Utilities.hs: -------------------------------------------------------------------------------- 1 | module Data.SWF.Internal.Utilities ( 2 | module Data.SWF.Internal.Utilities, 3 | 4 | module Control.Arrow, 5 | module Control.Monad, 6 | module Data.Maybe, 7 | module Data.List, 8 | module Debug.Trace, 9 | module Numeric 10 | ) where 11 | 12 | import Control.Arrow (first, second, (&&&), (***)) 13 | import Control.Monad 14 | 15 | import Data.Maybe 16 | import Data.List 17 | 18 | import Debug.Trace 19 | 20 | import Numeric 21 | 22 | 23 | orElse = flip fromMaybe 24 | 25 | fst3 (a, _, _) = a 26 | snd3 (_, b, _) = b 27 | thd3 (_, _, c) = c 28 | 29 | fst4 (a, _, _, _) = a 30 | snd4 (_, b, _, _) = b 31 | thd4 (_, _, c, _) = c 32 | fth4 (_, _, _, d) = d 33 | 34 | assertM True _ = return () 35 | assertM False s = fail s 36 | 37 | condM :: Monad m => m Bool -> m a -> m a -> m a 38 | condM mcond mt mf = do 39 | cond <- mcond 40 | if cond then mt else mf 41 | 42 | 43 | consistentWith :: Bool -> Bool -> Bool -> Bool 44 | consistentWith _ True True = True 45 | consistentWith _ False False = False 46 | consistentWith inconsis _ _ = inconsis 47 | 48 | inconsistent :: String -> String -> a 49 | inconsistent selector why 50 | = error $ unlines ["Data.SWF: Inconsistent state when writing back!", 51 | "Reason: " ++ why, 52 | "Selector: " ++ selector] 53 | 54 | maybeHasM :: Monad m => m Bool -> m b -> m (Maybe b) 55 | maybeHasM ma mb = ma >>= \a -> maybeHas a mb 56 | 57 | maybeHas :: Monad m => Bool -> m b -> m (Maybe b) 58 | maybeHas flag act 59 | | flag = liftM Just act 60 | | otherwise = return Nothing 61 | 62 | genericReplicateM :: (Integral a, Monad m) => a -> m b -> m [b] 63 | genericReplicateM n act = sequence $ genericReplicate n act 64 | 65 | isLeft :: Either a b -> Bool 66 | isLeft (Left _) = True 67 | isLeft _ = False 68 | 69 | 70 | padTo :: Int -> a -> [a] -> [a] 71 | padTo n c xs = replicate (n - length xs) c ++ xs 72 | 73 | showBinary :: Integral a => a -> ShowS 74 | showBinary x = showIntAtBase 2 (\d -> toEnum (fromEnum '0' + d)) (fromIntegral x) 75 | 76 | 77 | the :: Eq a => String -> String -> [a] -> Maybe a 78 | the _ _ [] = Nothing 79 | the selector why (x:xs) | all (x==) xs = Just x 80 | | otherwise = inconsistent selector why 81 | -------------------------------------------------------------------------------- /tests/Roundtripping.hs: -------------------------------------------------------------------------------- 1 | module Roundtripping where 2 | 3 | import TestUtilities 4 | 5 | import Control.Monad 6 | 7 | import qualified Data.ByteString.Lazy as BS 8 | import Data.List 9 | import Data.Ord 10 | 11 | import System.Directory 12 | import System.IO 13 | 14 | 15 | main :: IO () 16 | main = do 17 | roundtripPrimitives 18 | roundtripFiles 19 | 20 | 21 | roundtripPrimitives :: IO () 22 | roundtripPrimitives = do 23 | quickCheck $ roundtrips getUI8 putUI8 24 | quickCheck $ roundtrips getUI16 putUI16 25 | quickCheck $ roundtrips getUI32 putUI32 26 | 27 | quickCheck $ roundtrips getSI8 putSI8 28 | quickCheck $ roundtrips getSI16 putSI16 29 | quickCheck $ roundtrips getSI32 putSI32 30 | 31 | quickCheck $ roundtrips getFLOAT16 putFLOAT16 . FLOAT16 32 | quickCheck $ roundtrips getFLOAT putFLOAT 33 | quickCheck $ roundtrips getDOUBLE putDOUBLE 34 | quickCheck $ roundtrips getEncodedU32 putEncodedU32 35 | 36 | let fitInto x n = x `mod` 2 ^ (n :: Int) 37 | fitIntoS _ 0 = 0 38 | fitIntoS x n = x `mod` 2 ^ (n - 1 :: Int) 39 | 40 | roundtripsBits' :: Eq a => (Int -> SwfGet a) -> (Int -> a -> SwfPut) -> Int -> a -> Bool 41 | roundtripsBits' getter putter n x = roundtrips (aligned $ getter n) (flushed . putter n) x 42 | quickCheck $ \n x -> (n >= 0 && n <= 32) ==> roundtripsBits' getUB putUB n (x `fitInto` n) 43 | quickCheck $ \n x -> (n >= 0 && n <= 32) ==> roundtripsBits' getUB putUB n (x `fitIntoS` n) 44 | quickCheck $ \n i d -> (n >= 0 && n <= 16) ==> roundtripsBits' getFB putFB (n + 16) (FIXED { fIXED_integer = i `fitIntoS` n, fIXED_decimal = d }) 45 | 46 | 47 | roundtrips :: Eq a => SwfGet a -> (a -> SwfPut) -> a -> Bool 48 | roundtrips getter putter what 49 | = runSwfGet "roundtrips" emptySwfEnv (runSwfPut emptySwfEnv (putter what)) getter == what 50 | 51 | 52 | findFiles :: (FilePath -> Bool) -> FilePath -> IO [FilePath] 53 | findFiles p dir = do 54 | entries <- fmap (filter (not . flip elem [".", ".."])) $ getDirectoryContents dir 55 | fmap concat $ forM (map (dir ) entries) $ \entry -> do 56 | is_file <- doesFileExist entry 57 | if is_file 58 | then return [entry | p entry] 59 | else findFiles p entry 60 | 61 | roundtripFiles :: IO () 62 | roundtripFiles = do 63 | files <- smallestFilesFirst =<< findFiles (".swf" `isSuffixOf`) "examples" 64 | mapM_ roundtripFile files 65 | 66 | roundtripFile :: FilePath -> IO () 67 | roundtripFile file = do 68 | putStrLn $ "Roundtripping " ++ file 69 | bs <- BS.readFile file 70 | let swf = getSwf bs 71 | bs' = putSwf swf 72 | swf' = getSwf bs' 73 | -- NB: do NOT test bs == bs', because we don't guarantee to preserve 74 | -- absolutely everything about the SWF -- only the "semantic" information. 75 | unless (swf == swf') $ do 76 | tmp_file <- fmap ( "roundtrip.swf") getTemporaryDirectory 77 | BS.writeFile tmp_file bs' 78 | sayNotEqual ["In " ++ file ++ " (vs. " ++ tmp_file ++ ")"] swf' swf 79 | 80 | 81 | smallestFilesFirst :: [FilePath] -> IO [FilePath] 82 | smallestFilesFirst fps = do 83 | sfps <- forM fps $ \fp -> do 84 | s <- fileSize fp 85 | return (s, fp) 86 | return $ map snd $ sortBy (comparing fst) sfps 87 | 88 | fileSize :: FilePath -> IO Integer 89 | fileSize fp = do 90 | h <- openBinaryFile fp ReadMode 91 | hFileSize h 92 | -------------------------------------------------------------------------------- /tests/TestUtilities.hs: -------------------------------------------------------------------------------- 1 | module TestUtilities ( 2 | module TestUtilities, 3 | 4 | module Data.SWF, 5 | module Data.SWF.Internal.Binary, 6 | module System.FilePath, 7 | module Test.QuickCheck 8 | ) where 9 | 10 | import Data.SWF 11 | import Data.SWF.Internal.Binary 12 | 13 | import Data.Int 14 | import Data.Word 15 | import qualified Data.ByteString.Lazy as BS 16 | 17 | import System.FilePath 18 | import System.Random 19 | 20 | import Test.QuickCheck (Arbitrary(..), Gen, Property, (==>), quickCheck, sized, choose, variant) 21 | 22 | 23 | arbitraryIntegral :: (Random a, Integral a, Bounded a, Ord a) => Gen a 24 | arbitraryIntegral = sized $ \n -> choose (0, min (fromIntegral n) maxBound) 25 | 26 | coarbitraryIntegral :: (Random a, Integral a, Bounded a, Ord a) => a -> Gen b -> Gen b 27 | coarbitraryIntegral n = variant (if n >= 0 then 2 * x else 2 * x + 1) 28 | where x = abs . fromIntegral $ n 29 | 30 | randomREnum (a, b) g = (\(x, y) -> (fromInteger x, y)) $ 31 | randomR (toInteger a, toInteger b) g 32 | 33 | randomEnum g = randomR (minBound, maxBound) g 34 | 35 | instance Arbitrary Word8 where 36 | arbitrary = arbitraryIntegral 37 | coarbitrary = coarbitraryIntegral 38 | 39 | instance Random Word8 where 40 | randomR = randomREnum 41 | random = randomEnum 42 | 43 | instance Arbitrary Word16 where 44 | arbitrary = arbitraryIntegral 45 | coarbitrary = coarbitraryIntegral 46 | 47 | instance Random Word16 where 48 | randomR = randomREnum 49 | random = randomEnum 50 | 51 | instance Arbitrary Word32 where 52 | arbitrary = arbitraryIntegral 53 | coarbitrary = coarbitraryIntegral 54 | 55 | instance Random Word32 where 56 | randomR = randomREnum 57 | random = randomEnum 58 | 59 | instance Arbitrary Word64 where 60 | arbitrary = arbitraryIntegral 61 | coarbitrary = coarbitraryIntegral 62 | 63 | instance Random Word64 where 64 | randomR = randomREnum 65 | random = randomEnum 66 | 67 | instance Arbitrary Int8 where 68 | arbitrary = arbitraryIntegral 69 | coarbitrary = coarbitraryIntegral 70 | 71 | instance Random Int8 where 72 | randomR = randomREnum 73 | random = randomEnum 74 | 75 | instance Arbitrary Int16 where 76 | arbitrary = arbitraryIntegral 77 | coarbitrary = coarbitraryIntegral 78 | 79 | instance Random Int16 where 80 | randomR = randomREnum 81 | random = randomEnum 82 | 83 | instance Arbitrary Int32 where 84 | arbitrary = arbitraryIntegral 85 | coarbitrary = coarbitraryIntegral 86 | 87 | instance Random Int32 where 88 | randomR = randomREnum 89 | random = randomEnum 90 | 91 | deriving instance Arbitrary EncodedU32 92 | deriving instance Random EncodedU32 93 | 94 | 95 | aligned :: SwfGet a -> SwfGet a 96 | aligned what = do { x <- what; byteAlign; return x } 97 | 98 | flushed :: SwfPutM a -> SwfPutM a 99 | flushed what = do { x <- what; flushBits; return x } 100 | 101 | readFileWords :: FilePath -> IO [Word8] 102 | readFileWords = fmap BS.unpack . BS.readFile 103 | 104 | runGet :: [Word8] -> SwfGet a -> a 105 | runGet = runSwfGet "runGet" emptySwfEnv . BS.pack 106 | 107 | runPut :: SwfPut -> [Word8] 108 | runPut = BS.unpack . runSwfPut emptySwfEnv 109 | 110 | runGetSwf :: [Word8] -> Swf 111 | runGetSwf = getSwf . BS.pack 112 | 113 | assertEquals :: (Eq a, Show a) => a -> a -> IO () 114 | assertEquals x y = if x == y then return () else sayNotEqual ["assertEquals failure"] x y 115 | 116 | sayNotEqual :: Show a => [String] -> a -> a -> b 117 | sayNotEqual msg x y = error (unlines $ msg ++ [show x, "/=", show y]) 118 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Args 4 | import Data.SWF 5 | 6 | import Control.Monad 7 | 8 | import qualified Data.ByteString.Lazy as BS 9 | import Data.Char 10 | import Data.Generics 11 | import Data.Int 12 | import Data.Word 13 | import Data.List 14 | 15 | import System.FilePath 16 | 17 | import Text.PrettyPrint.HughesPJ 18 | 19 | 20 | main :: IO () 21 | main = do 22 | hswf <- getArgs 23 | 24 | forM_ (files hswf) $ \file -> do 25 | putStrLn $ "### Reading " ++ file 26 | swf <- fmap getSwf $ BS.readFile file 27 | 28 | case hswf of 29 | Debug{..} -> do 30 | if incremental 31 | then do 32 | print $ swf { swf_tags = [] } 33 | forM_ (swf_tags swf) print 34 | else 35 | print swf 36 | Decode{..} -> do 37 | writeFile (replaceExtension file ".out.hs") $ show $ vcat [ 38 | text "import qualified Data.ByteString.Lazy as BS", 39 | text "import Data.Char", 40 | text "import Data.SWF.Format", 41 | text "import Data.Ratio", 42 | text "", 43 | text "main = BS.writeFile" <+> text (show (replaceExtension file ".out.swf")) <+> text "(putSwf swf)", 44 | text "", 45 | text "bs x = BS.pack (map (fromIntegral . ord) x)", 46 | text "", 47 | text "swf =", 48 | nest 2 (prettyHaskell swf) 49 | ] 50 | 51 | 52 | prettyHaskell :: Data a => a -> Doc 53 | prettyHaskell = algebraic `extQ` string `extQ` bytestring `extQ` fixed8 `extQ` fixed `extQ` 54 | numeric (undefined :: Word8) `extQ` numeric (undefined :: Word16) `extQ` numeric (undefined :: Word32) `extQ` 55 | numeric (undefined :: Int8) `extQ` numeric (undefined :: Int16) `extQ` numeric (undefined :: Int32) 56 | where 57 | algebraic :: Data a => a -> Doc 58 | algebraic t 59 | | Just (FlipArrow f) <- dataCast1 (FlipArrow list) = f t 60 | | Just d <- tupleDataCast (\xs -> parens $ hsep $ punctuate (char ',') $ map (\(WithData x) -> prettyHaskell x) xs) t = d 61 | | null field_names = hang (text (showConstr constr)) 2 (vcat [parens doc | doc <- gmapQ prettyHaskell t]) 62 | | otherwise = hang (text (showConstr constr) <+> char '{') 2 ( 63 | nest 2 (vcat $ punctuate (char ',') [text field <+> char '=' <+> doc 64 | | (field, doc) <- field_names `zip` gmapQ prettyHaskell t]) $$ 65 | char '}' 66 | ) 67 | where constr = toConstr t 68 | field_names = constrFields constr 69 | 70 | string :: String -> Doc 71 | string = text . show 72 | 73 | bytestring :: BS.ByteString -> Doc 74 | bytestring bs = text "bs" <+> string (map (chr . fromIntegral) (BS.unpack bs)) 75 | 76 | numeric :: Integral a => a -> a -> Doc 77 | numeric _ = text . show 78 | 79 | fixed8 :: FIXED8 -> Doc 80 | fixed8 x = text "rationalToFIXED8" <+> parens (text $ show $ fIXED8ToRational x) 81 | 82 | fixed :: FIXED -> Doc 83 | fixed x = text "rationalToFIXED" <+> parens (text $ show $ fIXEDToRational x) 84 | 85 | list :: Data a => [a] -> Doc 86 | list [] = text "[]" 87 | list [x] = char '[' <> prettyHaskell x <> char ']' 88 | list xs = char '[' $$ vcat (punctuate (char ',') (map prettyHaskell xs)) $$ char ']' 89 | 90 | newtype FlipArrow b a = FlipArrow (a -> b) 91 | 92 | data WithData = forall a. Data a => WithData a 93 | 94 | instance Show WithData where show _ = "WithData" 95 | 96 | tupleDataCast :: Data a => ([WithData] -> c) -> a -> Maybe c 97 | tupleDataCast f t | Just (s, _) <- find (\(_, tcon) -> dataTypeName (dataTypeOf t) == dataTypeName (constrType tcon) && toConstr t == tcon) tuples 98 | -- See http://hackage.haskell.org/trac/ghc/ticket/3866 99 | = Just (f [gmapQi i WithData t | i <- [0..s - 1]]) 100 | | otherwise = Nothing 101 | where tuples = [2..] `zip` [toConstr ((), ()), toConstr ((), (), ()), toConstr ((), (), (), ()), toConstr ((), (), (), (), ()), toConstr ((), (), (), (), (), ())] -------------------------------------------------------------------------------- /tests/SpecificationExample.hs: -------------------------------------------------------------------------------- 1 | module SpecificationExample where 2 | 3 | import TestUtilities 4 | 5 | main :: IO () 6 | main = do 7 | swf_bytes <- io_swf_bytes 8 | runGetSwf swf_bytes `assertEquals` swf 9 | 10 | 11 | io_swf_bytes = readFileWords $ "examples" "spec" "example.swf" 12 | 13 | swf = Swf { 14 | swf_compressed = False, 15 | swf_version = 3, 16 | swf_frameSize = RECT { 17 | rECT_xmin = 0, 18 | rECT_xmax = 11000, 19 | rECT_ymin = 0, 20 | rECT_ymax = 8000 21 | }, 22 | swf_frameRate = FIXED8 { 23 | fIXED8_decimal = 0, 24 | fIXED8_integer = 12 25 | }, 26 | swf_frameCount = 1, 27 | swf_tags = [ 28 | SetBackgroundColor { 29 | setBackgroundColor_backgroundColor = RGB { 30 | rGB_red = 255, 31 | rGB_green = 255, 32 | rGB_blue = 255 33 | } 34 | }, 35 | DefineShape { 36 | defineShape_shapeId = 1, 37 | defineShape_shapeBounds = RECT { 38 | rECT_xmin = 2010, 39 | rECT_xmax = 4910, 40 | rECT_ymin = 1670, 41 | rECT_ymax = 4010 42 | }, 43 | defineShape_shapes = SHAPEWITHSTYLE { 44 | sHAPEWITHSTYLE_fillStyles = [], 45 | sHAPEWITHSTYLE_lineStyles = Left [ 46 | LINESTYLE { 47 | lINESTYLE_width = 20, 48 | lINESTYLE_color = Left (RGB { 49 | rGB_red = 0, 50 | rGB_green = 0, 51 | rGB_blue = 0 52 | }) 53 | } 54 | ], 55 | sHAPEWITHSTYLE_shapeRecords = [ 56 | STYLECHANGERECORD { 57 | sTYLECHANGERECORD_move = Just (14, 58 | 4900, 59 | 1680), 60 | sTYLECHANGERECORD_fillStyle0 = Nothing, 61 | sTYLECHANGERECORD_fillStyle1 = Nothing, 62 | sTYLECHANGERECORD_lineStyle = Just 1, 63 | sTYLECHANGERECORD_new = Nothing 64 | }, 65 | STRAIGHTEDGERECORD { 66 | sTRAIGHTEDGERECORD_numBits = 11, 67 | sTRAIGHTEDGERECORD_straightEdge = VerticalLine { 68 | straightEdge_deltaY = 2320 69 | } 70 | }, 71 | STRAIGHTEDGERECORD { 72 | sTRAIGHTEDGERECORD_numBits = 11, 73 | sTRAIGHTEDGERECORD_straightEdge = HorizontalLine { 74 | straightEdge_deltaX = -2880 75 | } 76 | }, 77 | STRAIGHTEDGERECORD { 78 | sTRAIGHTEDGERECORD_numBits = 11, 79 | sTRAIGHTEDGERECORD_straightEdge = VerticalLine { 80 | straightEdge_deltaY = -2320 81 | } 82 | }, 83 | STRAIGHTEDGERECORD { 84 | sTRAIGHTEDGERECORD_numBits = 11, 85 | sTRAIGHTEDGERECORD_straightEdge = HorizontalLine { 86 | straightEdge_deltaX = 2880 87 | } 88 | } 89 | ] 90 | } 91 | }, 92 | PlaceObject2 { 93 | placeObject2_placeFlagMove = False, 94 | placeObject2_depth = 1, 95 | placeObject2_characterId = Just 1, 96 | placeObject2_matrix = Just (MATRIX { 97 | mATRIX_scale = Nothing, 98 | mATRIX_rotate = Nothing, 99 | mATRIX_translateX = 0, 100 | mATRIX_translateY = 0 101 | }), 102 | placeObject2_colorTransform = Nothing, 103 | placeObject2_ratio = Nothing, 104 | placeObject2_name = Nothing, 105 | placeObject2_clipDepth = Nothing, 106 | placeObject2_clipActions = Nothing 107 | }, 108 | ShowFrame, 109 | End 110 | ] 111 | } -------------------------------------------------------------------------------- /tests/DefineShapeAlignment.hs: -------------------------------------------------------------------------------- 1 | module DefineShapeAlignment where 2 | 3 | import TestUtilities 4 | 5 | 6 | main = runGet define_shape_bytes getDefineShape `assertEquals` define_shape 7 | 8 | -- Observed in flash-gordon/blue.swf: if MATRIX records don't end by being 9 | -- byte aligned then this will parse incorrectly (the gradient list will be 10 | -- empty because you confuse padding with part of the GRADIENT entry). 11 | define_shape_bytes = [ 12 | 0x16, 0x00, 0x86, 0x4A, 0xF2, 0xD9, 0xAE, 0x3E, 13 | 0x71, 0xBB, 0xD8, 0x01, 0x10, 0x95, 0x2D, 0xC3, 14 | 0x0A, 0x79, 0x81, 0x91, 0xE4, 0xE2, 0xAB, 0xE1, 15 | 0x80, 0x02, 0x00, 0xFF, 0xFF, 0xFF, 0xFF, 0x10, 16 | 0x59, 0x9C, 0x00, 0x10, 0x16, 0x0B, 0x66, 0xA6, 17 | 0xB5, 0x3B, 0xAC, 0xAA, 0x40, 0xCC, 0xAE, 0xE0, 18 | 0x3F, 0x65, 0x7E, 0x64, 0x57, 0xBF, 0x12, 0x3A, 19 | 0xFF, 0x2D, 0xBB, 0x60, 0x00 20 | ] 21 | 22 | define_shape = DefineShape { 23 | defineShape_shapeId = 22, 24 | defineShape_shapeBounds = RECT { 25 | rECT_xmin = -13986, 26 | rECT_xmax = 23349, 27 | rECT_ymin = -14386, 28 | rECT_ymax = 14203}, 29 | defineShape_shapes = SHAPEWITHSTYLE { 30 | sHAPEWITHSTYLE_fillStyles = [ 31 | GradientFill { 32 | fILLSTYLE_linearRadial = Linear, 33 | fILLSTYLE_gradientMatrix = MATRIX { 34 | mATRIX_scale = Just (FIXED {fIXED_decimal = 9, fIXED_integer = 0},FIXED {fIXED_decimal = 13, fIXED_integer = 0}), 35 | mATRIX_rotate = Just (FIXED {fIXED_decimal = 49822, fIXED_integer = 0},FIXED {fIXED_decimal = 24676, fIXED_integer = 0}), 36 | mATRIX_translateX = 5002, 37 | mATRIX_translateY = -10301 38 | }, 39 | fILLSTYLE_gradient = GRADIENT { 40 | gRADIENT_spreadMode = 0, 41 | gRADIENT_interpolationMode = 0, 42 | gRADIENT_gradientRecords = [ 43 | GRADRECORD { 44 | gRADRECORD_ratio = 0, 45 | gRADRECORD_color = Left (RGB { 46 | rGB_red = 255, 47 | rGB_green = 255, 48 | rGB_blue = 255 49 | }) 50 | }, 51 | GRADRECORD { 52 | gRADRECORD_ratio = 255, 53 | gRADRECORD_color = Left (RGB { 54 | rGB_red = 16, 55 | rGB_green = 89, 56 | rGB_blue = 156 57 | }) 58 | } 59 | ] 60 | } 61 | } 62 | ], 63 | sHAPEWITHSTYLE_lineStyles = Left [], 64 | sHAPEWITHSTYLE_shapeRecords = [ 65 | STYLECHANGERECORD { 66 | sTYLECHANGERECORD_move = Just (16,23349,13737), 67 | sTYLECHANGERECORD_fillStyle0 = Nothing, 68 | sTYLECHANGERECORD_fillStyle1 = Just 1, 69 | sTYLECHANGERECORD_lineStyle = Nothing, 70 | sTYLECHANGERECORD_new = Nothing 71 | }, 72 | CURVEDEDGERECORD { 73 | cURVEDEDGERECORD_controlDeltaX = -19799, 74 | cURVEDEDGERECORD_controlDeltaY = 818, 75 | cURVEDEDGERECORD_anchorDeltaX = -17536, 76 | cURVEDEDGERECORD_anchorDeltaY = -619 77 | }, 78 | STRAIGHTEDGERECORD { 79 | sTRAIGHTEDGERECORD_numBits = 14, 80 | sTRAIGHTEDGERECORD_straightEdge = VerticalLine { 81 | straightEdge_deltaY = -28322 82 | } 83 | }, 84 | STRAIGHTEDGERECORD { 85 | sTRAIGHTEDGERECORD_numBits = 15, 86 | sTRAIGHTEDGERECORD_straightEdge = HorizontalLine { 87 | straightEdge_deltaX = 37335 88 | } 89 | }, 90 | STRAIGHTEDGERECORD { 91 | sTRAIGHTEDGERECORD_numBits = 14, 92 | sTRAIGHTEDGERECORD_straightEdge = VerticalLine { 93 | straightEdge_deltaY = 28123 94 | } 95 | } 96 | ] 97 | } 98 | } 99 | -------------------------------------------------------------------------------- /generator/Cleaner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module Main where 3 | 4 | import Data.Char 5 | import Data.List 6 | 7 | 8 | -- CONVOLUTIONFILTER 9 | -- Field Type Comment 10 | -- MatrixX UI8 Horizontal matrix size 11 | -- MatrixY UI8 Vertical matrix size 12 | -- Divisor FLOAT Divisor applied to the 13 | -- matrix values 14 | -- Bias FLOAT Bias applied to the matrix 15 | -- values 16 | -- Matrix FLOAT[MatrixX * MatrixY] Matrix values 17 | -- DefaultColor RGBA Default color for pixels 18 | -- outside the image 19 | -- Reserved UB[6] Must be 0 20 | -- Clamp UB[1] Clamp mode 21 | -- PreserveAlpha UB[1] Preserve the alpha 22 | 23 | main = interact (unlines . waitForAll . wrapRecord . fixupIndentation . fixupLineBreaks . killBlanks . lines) 24 | 25 | waitForAll :: [String] -> [String] 26 | waitForAll xs = length xs `seq` xs 27 | 28 | killBlanks :: [String] -> [String] 29 | killBlanks = filter (not . null) . map strip 30 | where strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace 31 | 32 | fixupLineBreaks :: [String] -> [String] 33 | fixupLineBreaks [] = [] 34 | fixupLineBreaks [l] = [l] 35 | fixupLineBreaks (l1:l2:ls) 36 | | (l2c:_) <- l2 37 | , let l2ws = words l2 38 | , isLower l2c || isDigit l2c || isSymbol l2c || length l2ws < 3 || "[" `isInfixOf` (head l2ws) || head l2ws == "If" 39 | = fixupLineBreaks ((l1 ++ ' ':l2):ls) 40 | | otherwise 41 | = l1 : fixupLineBreaks (l2:ls) 42 | 43 | -- CONVOLUTIONFILTER 44 | -- Field Type Comment 45 | -- MatrixX UI8 Horizontal matrix size 46 | -- MatrixY UI8 Vertical matrix size 47 | -- Divisor FLOAT Divisor applied to the matrix values 48 | -- Bias FLOAT Bias applied to the matrix values 49 | -- Matrix FLOAT[MatrixX * MatrixY] Matrix values 50 | -- DefaultColor RGBA Default color for pixels outside the image 51 | -- Reserved UB[6] Must be 0 52 | -- Clamp UB[1] Clamp mode 53 | -- PreserveAlpha UB[1] Preserve the alpha 54 | 55 | fixupIndentation :: [String] -> [String] 56 | fixupIndentation (name:ls) 57 | | all (not . isSpace) name 58 | = name : go ls 59 | | otherwise 60 | = head (words (head ls)) : go (name : ls) 61 | where 62 | go ls = [pad fieldname typindent ++ pad typ commentindent ++ comment | (fieldname, typ, comment) <- considered_ls] 63 | where 64 | pad s n = s ++ replicate (n - length s) ' ' 65 | 66 | considered_ls = zipWith consider (True:repeat False) ls 67 | 68 | (fieldnames, typs, comments) = unzip3 considered_ls 69 | typindent = maximum (map length fieldnames) + 1 70 | commentindent = maximum (map length typs) + 1 71 | 72 | consider headerline l = (fieldname, unwords typ, unwords comment) 73 | where 74 | fieldname:ws = words l 75 | (typ, comment) = breakRev partOfTypeField ws 76 | 77 | partOfTypeField w = looksLikeType w || (w == "Type" && headerline) || partOfArrayExpr w 78 | 79 | looksLikeType w = length w > 1 && 80 | w /= "ID" && w /= "SWF" && w /= "URL" && 81 | length (fst (span (\c -> isUpper c || isDigit c) (dropPrefix "Encoded" w))) >= 2 && 82 | all (not . (`isInfixOf` w)) [")", "("] && 83 | not (all (\c -> isDigit c || isSymbol c) w) 84 | partOfArrayExpr w = any (`isInfixOf` w) ["*", "+", "]", "["] 85 | 86 | dropPrefix pr xs | take (length pr) xs == pr = drop (length pr) xs 87 | | otherwise = xs 88 | 89 | breakRev p xs = case break p (reverse xs) of (as, bs) -> (reverse bs, reverse as) 90 | 91 | -- CONVOLUTIONFILTER 92 | -- Field Type Comment 93 | -- MatrixX UI8 Horizontal matrix size 94 | -- MatrixY UI8 Vertical matrix size 95 | -- Divisor FLOAT Divisor applied to the matrix values 96 | -- Bias FLOAT Bias applied to the matrix values 97 | -- Matrix FLOAT[MatrixX * MatrixY] Matrix values 98 | -- DefaultColor RGBA Default color for pixels outside the image 99 | -- Reserved UB[6] Must be 0 100 | -- Clamp UB[1] Clamp mode 101 | -- PreserveAlpha UB[1] Preserve the alpha 102 | 103 | wrapRecord ls = "\\begin{record}" : ls ++ ["\\end{record}"] 104 | -------------------------------------------------------------------------------- /Data/SWF/Internal/Binary.hs: -------------------------------------------------------------------------------- 1 | module Data.SWF.Internal.Binary ( 2 | module Data.SWF.Internal.Binary, 3 | 4 | module Data.Bits, 5 | module Data.ByteString.Lazy, 6 | module Data.Int, 7 | module Data.Word 8 | ) where 9 | 10 | import Data.SWF.Internal.Utilities 11 | 12 | import Codec.Compression.Zlib 13 | 14 | import qualified Data.Binary as B 15 | import qualified Data.Binary.Get as B 16 | import qualified Data.Binary.Put as B 17 | 18 | import Data.Bits 19 | import Data.ByteString.Lazy (ByteString) 20 | import qualified Data.ByteString.Lazy as BS 21 | import Data.Int 22 | import Data.Word 23 | 24 | 25 | class Eq a => ReservedDefault a where 26 | reservedDefault :: a 27 | 28 | instance ReservedDefault () where reservedDefault = () -- Only intended for use with flushBits! 29 | instance ReservedDefault Bool where reservedDefault = False 30 | instance ReservedDefault Word8 where reservedDefault = 0 31 | instance ReservedDefault Word16 where reservedDefault = 0 32 | instance ReservedDefault Word32 where reservedDefault = 0 33 | instance ReservedDefault Int8 where reservedDefault = 0 34 | instance ReservedDefault Int16 where reservedDefault = 0 35 | instance ReservedDefault Int32 where reservedDefault = 0 36 | 37 | 38 | newtype SwfEnv = SwfEnv { 39 | swfVersion :: Word8 40 | } 41 | 42 | emptySwfEnv :: SwfEnv 43 | emptySwfEnv = SwfEnv { swfVersion = error "swfVersion not known yet!" } 44 | 45 | 46 | -- Getting data 47 | 48 | newtype SwfGet a = SwfGet { unSwfGet :: SwfEnv -> Word8 -> Int -> B.Get (Word8, Int, a) } 49 | 50 | instance Functor SwfGet where 51 | fmap = liftM 52 | 53 | instance Monad SwfGet where 54 | return x = SwfGet $ \_ byte nbits -> return (byte, nbits, x) 55 | mx >>= fxmy = SwfGet $ \env byte nbits -> unSwfGet mx env byte nbits >>= \(byte, nbits, x) -> unSwfGet (fxmy x) env byte nbits 56 | 57 | modifySwfGet :: (SwfEnv -> SwfEnv) -> SwfGet a -> SwfGet a 58 | modifySwfGet f act = SwfGet $ \env byte nbits -> unSwfGet act (f env) byte nbits 59 | 60 | getSwfGet :: SwfGet SwfEnv 61 | getSwfGet = SwfGet $ \env byte nbits -> return (byte, nbits, env) 62 | 63 | runSwfGet :: String -> SwfEnv -> ByteString -> SwfGet a -> a 64 | runSwfGet hint env bs mx = thd3 $ B.runGet (unSwfGet (checkConsumesAll hint mx) env 0 0) bs 65 | 66 | 67 | checkConsumesAll :: String -> SwfGet a -> SwfGet a 68 | checkConsumesAll hint mx = SwfGet $ \env byte nbits -> do 69 | (byte, nbits, x) <- unSwfGet mx env byte nbits 70 | nbytes <- B.remaining 71 | if nbytes /= 0 72 | then do 73 | remainder <- B.getRemainingLazyByteString 74 | error $ hint ++ ": " ++ show nbytes ++ " trailing bytes - likely to be an error\n" ++ show remainder 75 | else 76 | if nbits /= 0 77 | then error $ hint ++ ": " ++ show nbits ++ " trailing bits - likely to be an error" 78 | else return (byte, nbits, x) 79 | 80 | 81 | nestSwfGetBS :: String -> B.Get ByteString -> SwfGet a -> SwfGet a 82 | nestSwfGetBS hint mrest mx = SwfGet $ \env _ nbits -> do 83 | if nbits /= 0 84 | then error $ hint ++ ": nesting off a byte boundary - likely to be an error" 85 | else do 86 | rest <- mrest 87 | return (0, 0, runSwfGet hint env rest mx) 88 | 89 | nestSwfGet :: Integral b => String -> b -> SwfGet a -> SwfGet a 90 | nestSwfGet hint len = nestSwfGetBS hint (B.getLazyByteString $ fromIntegral len) 91 | 92 | decompressRemainder :: Int -> SwfGet a -> SwfGet a 93 | decompressRemainder size_hint = nestSwfGetBS "decompressRemainder" (fmap decompress (B.getLazyByteString maxBound)) 94 | where decompress = decompressWith (defaultDecompressParams { decompressBufferSize = size_hint }) 95 | 96 | 97 | discardReserved :: ReservedDefault a => String -> SwfGet a -> SwfGet () 98 | discardReserved selector = discardKnown selector "Reserved data must be 0" reservedDefault 99 | 100 | discardKnown :: Eq a => String -> String -> a -> SwfGet a -> SwfGet () 101 | discardKnown selector why known mx = do 102 | x <- mx 103 | unless (x == known) $ inconsistent selector why 104 | 105 | 106 | liftGet :: B.Get a -> SwfGet a 107 | liftGet get = SwfGet $ \_ byte nbits -> fmap (byte, nbits,) get 108 | 109 | getWord8 = byteAlign >> liftGet B.getWord8 110 | 111 | getWord16 = byteAlign >> liftGet B.getWord16le 112 | 113 | getWord32 = byteAlign >> liftGet B.getWord32le 114 | 115 | getWord64 = byteAlign >> liftGet B.getWord64le 116 | 117 | getLazyByteString len = byteAlign >> liftGet (B.getLazyByteString len) 118 | 119 | getLazyByteStringNul = byteAlign >> liftGet B.getLazyByteStringNul 120 | 121 | -- NB: do NOT use getRemainingLazyByteString here, because it consumes 0 bytes if we don't 122 | -- deepseq the thing consuming it, and that gets reported as too few bytes being consumed 123 | -- from the non-nested stream. Delegate reporting that error to any *nested* runSwfGet call! 124 | getRemainingLazyByteString = getLazyByteString maxBound 125 | 126 | getBits :: Integral a => a -> SwfGet Word32 127 | getBits n | n < 0 = error "getBits: negative bits" 128 | | n > 32 = error "getBits: bit count greater than 32" 129 | | otherwise = SwfGet $ \_ byte nbits -> go byte nbits (fromIntegral n) 130 | where 131 | go byte nbits want_nbits 132 | -- Can we satisfy ourselves with just the bits from this byte? 133 | | want_nbits <= nbits = return (byte, nbits - want_nbits, fromIntegral (byte `shiftR` fromIntegral (nbits - want_nbits)) .&. (2 ^ want_nbits - 1)) 134 | -- We need at least some of the next byte 135 | | otherwise = do 136 | let want_nbits' = want_nbits - nbits 137 | this = fromIntegral (byte .&. (2 ^ nbits - 1)) `shiftL` fromIntegral want_nbits' 138 | byte <- B.getWord8 139 | (byte, nbits, rest) <- go byte 8 want_nbits' 140 | return (byte, nbits, this .|. rest) 141 | 142 | getToEnd :: SwfGet a -> SwfGet [a] 143 | getToEnd mx = condM isEmpty (return []) $ do 144 | x <- mx 145 | fmap (x:) $ getToEnd mx 146 | 147 | isEmpty = liftGet B.isEmpty 148 | 149 | lookAhead :: SwfGet a -> SwfGet a 150 | lookAhead mx = SwfGet $ \env byte nbits -> fmap ((byte, nbits,) . thd3) (B.lookAhead (unSwfGet mx env byte nbits)) 151 | 152 | byteAlign :: SwfGet () 153 | byteAlign = SwfGet $ \env bytes nbits -> do 154 | (_, 0, remaining) <- unSwfGet (getBits nbits) env bytes nbits 155 | if remaining /= 0 156 | then error "Byte alignment discarded non-zero bits - probably an error" 157 | else return (0, 0, ()) 158 | 159 | -- Putting data pack 160 | 161 | type SwfPut = SwfPutM () 162 | 163 | newtype SwfPutM a = SwfPutM { unSwfPutM :: SwfEnv -> Word8 -> Int -> B.PutM (Word8, Int, a) } 164 | 165 | instance Functor SwfPutM where 166 | fmap = liftM 167 | 168 | instance Monad SwfPutM where 169 | return x = SwfPutM $ \_ byte nbits -> return (byte, nbits, x) 170 | mx >>= fxmy = SwfPutM $ \env byte nbits -> do 171 | (byte, nbits, x) <- unSwfPutM mx env byte nbits 172 | unSwfPutM (fxmy x) env byte nbits 173 | 174 | modifySwfPutM :: (SwfEnv -> SwfEnv) -> SwfPutM a -> SwfPutM a 175 | modifySwfPutM f act = SwfPutM $ \env byte nbits -> unSwfPutM act (f env) byte nbits 176 | 177 | getSwfPutM :: SwfPutM SwfEnv 178 | getSwfPutM = SwfPutM $ \env byte nbits -> return (byte, nbits, env) 179 | 180 | runSwfPutM :: SwfEnv -> SwfPutM a -> (a, ByteString) 181 | runSwfPutM env mx = first thd3 $ B.runPutM (unSwfPutM (checkFlushesAll mx) env 0 8) 182 | 183 | runSwfPut :: SwfEnv -> SwfPut -> ByteString 184 | runSwfPut env = snd . runSwfPutM env 185 | 186 | checkFlushesAll :: SwfPutM a -> SwfPutM a 187 | checkFlushesAll mx = SwfPutM $ \env byte nbits -> do 188 | (byte, nbits, x) <- unSwfPutM mx env byte nbits 189 | if nbits /= 8 190 | then error $ show (8 - nbits) ++ " unwritten bits - almost certainly an error" 191 | else return (byte, nbits, x) 192 | 193 | 194 | nestSwfPutMBS :: (a -> ByteString -> B.PutM b) -> SwfPutM a -> SwfPutM b 195 | nestSwfPutMBS f mx = SwfPutM $ \env _ nbits -> 196 | if nbits /= 8 197 | then error $ show nbits ++ " desired bits when we reach a nested write - probably an error" 198 | else do 199 | let (x, bs) = runSwfPutM env mx 200 | y <- f x bs 201 | return (0, 8, y) 202 | 203 | nestSwfPutM :: Integral b => SwfPutM a -> SwfPutM (a, (b, SwfPut)) 204 | nestSwfPutM = nestSwfPutMBS (\x bs -> return (x, (fromIntegral $ BS.length bs, putLazyByteString bs))) 205 | 206 | nestSwfPut :: Integral b => SwfPut -> SwfPutM (b, SwfPut) 207 | nestSwfPut = fmap snd . nestSwfPutM 208 | 209 | compressRemainder :: Integral b => SwfPutM a -> SwfPutM (a, (b, SwfPut)) 210 | compressRemainder = nestSwfPutMBS (\x bs -> return (x, (fromIntegral $ BS.length bs, putLazyByteString (compress bs)))) 211 | where compress = compressWith defaultCompressParams 212 | 213 | 214 | liftPut :: B.PutM a -> SwfPutM a 215 | liftPut put = SwfPutM $ \_ byte nbits -> fmap (byte, nbits,) put 216 | 217 | putWord8 x = flushBits >> liftPut (B.putWord8 x) 218 | 219 | putWord16 x = flushBits >> liftPut (B.putWord16le x) 220 | 221 | putWord32 x = flushBits >> liftPut (B.putWord32le x) 222 | 223 | putWord64 x = flushBits >> liftPut (B.putWord64le x) 224 | 225 | putLazyByteString x = flushBits >> liftPut (B.putLazyByteString x) 226 | 227 | putLazyByteStringNul x = flushBits >> liftPut (B.putLazyByteString x >> B.putWord8 0) 228 | 229 | putBits :: Integral a => a -> Word32 -> SwfPut 230 | putBits n x | n < 0 = error "putBits: negative bits" 231 | | n > 32 = error "putBits: bit count greater than 32" 232 | | otherwise = SwfPutM $ \_ byte nbits -> go byte nbits (fromIntegral n) x 233 | where 234 | go :: Word8 -> Int -> Int -> Word32 -> B.PutM (Word8, Int, ()) 235 | go byte want_nbits nbits x 236 | -- Can we now output a complete byte? 237 | | want_nbits <= nbits = do 238 | B.putWord8 (byte .|. fromIntegral (x `shiftR` (nbits - want_nbits))) 239 | let nbits' = nbits - want_nbits 240 | rest_mask = (1 `shiftL` nbits') - 1 241 | go 0 8 nbits' (x .&. rest_mask) 242 | -- We need at least 1 more bit to output something 243 | | otherwise = return (byte .|. fromIntegral (x `shiftL` (want_nbits - nbits)), want_nbits - nbits, ()) 244 | 245 | flushBits :: SwfPut 246 | flushBits = SwfPutM $ \_ byte nbits -> when (nbits /= 8) (B.putWord8 byte) >> return (0, 8, ()) 247 | -------------------------------------------------------------------------------- /generator/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, PatternGuards, DeriveDataTypeable, FlexibleContexts #-} 2 | module Main where 3 | 4 | import Control.Arrow (first) 5 | import Control.Monad 6 | import Control.Monad.Writer 7 | 8 | import Data.Char 9 | import Data.Data (Data, Typeable) 10 | import Data.Generics.Uniplate.Data 11 | import Data.List 12 | import Data.List.Split (split, keepDelimsR, condense, oneOf) 13 | import Data.Maybe 14 | import qualified Data.Map as M 15 | import qualified Data.Set as S 16 | 17 | import System.Environment 18 | import System.IO 19 | 20 | import Text.ParserCombinators.Parsec hiding (oneOf) 21 | import Text.ParserCombinators.Parsec.Expr 22 | 23 | import Numeric 24 | 25 | import Language.Haskell.Exts.Syntax hiding (Type, TyCon, Assoc(..)) 26 | import qualified Language.Haskell.Exts.Syntax as LHE 27 | import qualified Language.Haskell.Exts.Parser as LHE 28 | import qualified Language.Haskell.Exts.Pretty as LHEP 29 | 30 | 31 | -- TODO: 32 | -- * Mark reserved fields with _ instead of detecting them 33 | -- * Don't generate consistency checks for condexpr and 34 | -- lenexpr that are the basis for excluding a field, since 35 | -- they will always be consistent with the rematerialised value 36 | 37 | 38 | main :: IO () 39 | main = do 40 | [file] <- getArgs 41 | chunks <- fmap parseFile $ readFile file 42 | 43 | --mapM_ (hPutStrLn stderr . show) [r | RecordChunk r <- chunks] 44 | --mapM_ (hPutStrLn stderr . LHEP.prettyPrint) $ concat [recordToDecls r | RecordChunk r <- chunks] 45 | 46 | let (specialinfos, lss) = unzip $ map (unParseChunk $ unionSpecialInfos specialinfos) chunks 47 | putStrLn $ unlines $ concat lss 48 | 49 | 50 | unParseChunk :: SpecialInfo -> Chunk -> (SpecialInfo, [String]) 51 | unParseChunk _ (NonRecordChunk ls) 52 | = (emptySpecialInfo, ls) 53 | unParseChunk _ (RecordChunk r) 54 | = (specialinfo, codeBlock decls) 55 | where (specialinfo, decls) = recordToDecls $ r { record_fields = identifyExclusions $ identifyComposites $ simplify $ record_fields r } 56 | unParseChunk (dispatcher_special, _) (GenFunctionsChunk gen) 57 | = (emptySpecialInfo, codeBlock [getter_decl, putter_decl, types_decl]) 58 | where 59 | dispatcher_decl dispatching dispatcher = FunBind [Match noSrcLoc (Ident $ "generated" ++ show gen ++ dispatching) [PVar (Ident var_name)] Nothing (UnGuardedRhs $ dispatcher var_name) (BDecls [])] 60 | where var_name = map toLower (show gen) 61 | 62 | getter_decl = dispatcher_decl "Getters" dispatcher 63 | where 64 | dispatcher x = Case (var x) (alts ++ [default_alt]) 65 | alts = [Alt noSrcLoc (PLit lit) (UnGuardedAlt (App (con "Just") (Var gettername))) (BDecls []) | (lit, gettername, _, _) <- M.findWithDefault [] gen dispatcher_special] 66 | default_alt = Alt noSrcLoc PWildCard (UnGuardedAlt (con "Nothing")) (BDecls []) 67 | 68 | putter_decl = dispatcher_decl "Putters" dispatcher 69 | where 70 | dispatcher x = Case (var x) (alts x) 71 | alts x = [Alt noSrcLoc pat (UnGuardedAlt (App (Var puttername) (var x))) (BDecls []) | (_, _, pat, puttername) <- M.findWithDefault [] gen dispatcher_special] 72 | 73 | types_decl = dispatcher_decl "Types" dispatcher 74 | where 75 | dispatcher x = Case (var x) alts 76 | alts = [Alt noSrcLoc pat (UnGuardedAlt (Lit lit)) (BDecls []) | (lit, _, pat, _) <- M.findWithDefault [] gen dispatcher_special] 77 | 78 | unParseChunk (_, datacon_special) (GenConstructorsChunk gen) 79 | = (emptySpecialInfo, [" " ++ (if firstalt then "=" else "|") ++ LHEP.prettyPrint datacon | (firstalt, datacon) <- (exhaustive : repeat False) `zip` datacons]) 80 | where exhaustive = gen == ShapeRecord 81 | datacons = M.findWithDefault [] gen datacon_special 82 | 83 | codeBlock ls = "\\begin{code}" : map LHEP.prettyPrint ls ++ ["", "\\end{code}"] 84 | 85 | 86 | data Generatable = Tag | Action | ShapeRecord 87 | deriving (Eq, Ord, Show) 88 | 89 | type SpecialInfo 90 | = (M.Map Generatable [(Literal, QName, Pat, QName)], 91 | -- Upon Lit, dispatch to getter with given QName, producing something 92 | -- matched by the Pat by the putter at QName 93 | M.Map Generatable [QualConDecl]) 94 | -- Output specified data constructor 95 | 96 | emptySpecialInfo = (M.empty, M.empty) 97 | 98 | unionSpecialInfos :: [SpecialInfo] -> SpecialInfo 99 | unionSpecialInfos sis = case unzip sis of 100 | (si1s, si2s) -> (M.unionsWith (++) si1s, M.unionsWith (++) si2s) 101 | 102 | 103 | data Chunk = NonRecordChunk [String] 104 | | RecordChunk Record 105 | | GenFunctionsChunk Generatable 106 | | GenConstructorsChunk Generatable 107 | deriving (Show) 108 | 109 | type RecordName = String 110 | 111 | data Record = Record { 112 | record_name :: RecordName, 113 | record_params :: [FieldName], 114 | record_fields :: [Field] 115 | } deriving (Show, Typeable, Data) 116 | 117 | type FieldName = String 118 | 119 | data Field = Field { 120 | field_name :: FieldName, 121 | field_type :: Type, 122 | field_comment :: String, 123 | field_excluded :: Maybe WhyExcluded 124 | } deriving (Show, Typeable, Data) 125 | 126 | data WhyExcluded = IsReserved 127 | | IsPresenceFlag FieldName 128 | | IsSelectFlag FieldName 129 | | IsLength FieldName 130 | | HasCustomSynthesiser [Stmt] Exp 131 | deriving (Show, Typeable, Data) 132 | 133 | data BitTyConName = UB | SB | FB 134 | deriving (Show, Typeable, Data) 135 | 136 | data TyCon = TyCon String [FieldExpr] 137 | | BitsTyCon BitTyConName FieldExpr 138 | deriving (Show, Typeable, Data) 139 | 140 | data Type = TyConType { type_tycon :: TyCon } 141 | | RepeatType { type_type :: Type, type_repeats :: Repeats } 142 | | IfThenType { type_cond :: FieldExpr, type_then :: Type } 143 | | IfThenElseType { type_cond :: FieldExpr, type_then :: Type, type_else :: Type } 144 | | CompositeType { type_fields :: [Field] } -- Inserted by analysis 145 | | TupleType { type_types :: [Type] } 146 | deriving (Show, Typeable, Data) 147 | 148 | data Repeats = NumberOfTimes FieldExpr 149 | | OptionallyAtEnd 150 | | RepeatsUntilEnd 151 | deriving (Show, Typeable, Data) 152 | 153 | data FieldExpr = LitE Int 154 | | FieldE FieldName 155 | | UnOpE FieldUnOp FieldExpr 156 | | BinOpE FieldBinOp FieldExpr FieldExpr 157 | deriving (Eq, Show, Typeable, Data) 158 | 159 | data FieldUnOp = Not 160 | deriving (Eq, Show, Typeable, Data) 161 | 162 | data FieldBinOp = Plus | Mult | Equals | NotEquals | Or | And 163 | deriving (Eq, Show, Typeable, Data) 164 | 165 | type_cond_maybe :: Type -> Maybe (Bool, FieldExpr) 166 | type_cond_maybe (IfThenType { type_cond }) = Just (True, type_cond) 167 | type_cond_maybe (IfThenElseType { type_cond }) = Just (False, type_cond) 168 | type_cond_maybe _ = Nothing 169 | 170 | freeFields :: (Biplate from FieldExpr) => from -> S.Set FieldName 171 | freeFields = execWriter . transformBiM go 172 | where go e@(FieldE fn) = tell (S.singleton fn) >> return e 173 | go e = return e 174 | 175 | parseFile :: String -> [Chunk] 176 | parseFile contents = goNo [] (lines contents) 177 | where 178 | goNo acc [] = [NonRecordChunk acc] 179 | goNo acc (l:ls) 180 | | Just chunk <- lookup l commands = NonRecordChunk acc : chunk : goNo [] ls 181 | | l == "\\begin{record}" = NonRecordChunk acc : goYes [] ls 182 | | otherwise = goNo (acc ++ [l]) ls 183 | where commands = [("\\genfunctions{tag}", GenFunctionsChunk Tag), 184 | ("\\genconstructors{tag}", GenConstructorsChunk Tag), 185 | ("\\genfunctions{action}", GenFunctionsChunk Action), 186 | ("\\genconstructors{action}", GenConstructorsChunk Action), 187 | ("\\genconstructors{shaperecord}", GenConstructorsChunk ShapeRecord)] 188 | 189 | goYes acc [] = error "Unclosed record!" 190 | goYes acc (l:ls) 191 | | l == "\\end{record}" = RecordChunk (parseRecordLines acc) : goNo [] ls 192 | | otherwise = goYes (acc ++ [l]) ls 193 | 194 | parseRecordLines :: [String] -> Record 195 | parseRecordLines (header_line:headers:ls) = Record name params (go1 ls) 196 | where 197 | (name, params) = parseExactly headerline header_line 198 | 199 | header_words = map length $ split (keepDelimsR $ condense $ oneOf " ") headers 200 | [name_offset, type_offset, _end_offset] = case header_words of [a, b, c] -> [a, b, c]; _ -> error ("parseRecordLines headers:\n" ++ show header_words) 201 | 202 | go1 [] = [] 203 | go1 (l:ls) = go2 (\below -> Field { field_name = strip name, field_type = typ, field_comment = comment, field_excluded = parseBelow below }) [] ls 204 | where (name, l') = splitAt name_offset l 205 | (typ_str, comment) = splitAt type_offset l' 206 | typ = case parseType (strip typ_str) of Left errs -> error (unlines [name, typ_str, show errs]); Right typ -> typ 207 | 208 | parseBelow [] = Nothing 209 | parseBelow ls = Just $ HasCustomSynthesiser (map (LHE.fromParseResult . LHE.parseStmt) (init ls)) (LHE.fromParseResult $ LHE.parseExp (last ls)) 210 | 211 | go2 f acc [] = [f $ reverse acc] 212 | go2 f acc (l:ls) 213 | | " " `isPrefixOf` l = go2 f (drop 2 l:acc) ls 214 | | otherwise = f (reverse acc) : go1 (l:ls) 215 | 216 | strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace 217 | 218 | 219 | parseExactly :: Parser a -> String -> a 220 | parseExactly ma s = case parse ma "" s of Left errs -> error (show errs); Right a -> a 221 | 222 | parseType :: String -> Either ParseError Type 223 | parseType s = parse (do { t <- typ; eof; return t }) "" s 224 | 225 | typ = try conditional 226 | <|> basetyp 227 | "type" 228 | 229 | basetyp = do 230 | optional <- optionality 231 | cons <- tycontyp <|> tupletyp 232 | mb_repeats <- if optional then return (Just OptionallyAtEnd) else optionMaybe repeatspecifier 233 | return $ maybe cons (RepeatType cons) mb_repeats 234 | 235 | repeatspecifier = between (char '[') (char ']' >> spaces) (fmap NumberOfTimes expr <|> return RepeatsUntilEnd) 236 | "repeat specifier" 237 | 238 | optionality = do { string "(optional)"; spaces; return True } 239 | <|> return False 240 | "optionality clause" 241 | 242 | conditional = do 243 | string "If"; spaces 244 | e <- expr; 245 | optional (char ','); spaces 246 | tt <- typ; 247 | mb_tf <- optionMaybe $ do 248 | string "Otherwise"; spaces 249 | optional (char ','); spaces 250 | typ 251 | return $ maybe (IfThenType e tt) (IfThenElseType e tt) mb_tf 252 | 253 | tycon = do 254 | tc <- many1 alphaNum 255 | case lookup tc [("UB", UB), ("SB", SB), ("FB", FB)] of 256 | Just btc -> do 257 | e <- between (char '[') (char ']' >> spaces) expr 258 | return $ BitsTyCon btc e 259 | Nothing -> do 260 | mb_args <- optionMaybe arguments; spaces 261 | return $ TyCon tc (fromMaybe [] mb_args) 262 | 263 | tycontyp = fmap TyConType tycon 264 | "type constructor" 265 | 266 | fieldname = do { x <- letter; xs <- many alphaNum; return (x:xs) } 267 | 268 | arguments = between (char '(') (char ')' >> spaces) (sepBy expr (char ',' >> spaces)) 269 | "arguments" 270 | 271 | parameters = between (char '(') (char ')' >> spaces) (sepBy fieldname (char ',' >> spaces)) 272 | "parameters" 273 | 274 | tupletyp = fmap tupleType $ between (char '<') (char '>' >> spaces) $ sepBy typ (char ',' >> spaces) 275 | where tupleType tys | [ty] <- tys = ty 276 | | otherwise = TupleType tys 277 | 278 | expr = buildExpressionParser table (do { e <- factor; spaces; return e }) 279 | "expression" 280 | 281 | table = [[op "*" (BinOpE Mult) AssocLeft], 282 | [op "+" (BinOpE Plus) AssocLeft], 283 | [op "=" (BinOpE Equals) AssocLeft, op "!=" (BinOpE NotEquals) AssocLeft], 284 | [op "and" (BinOpE And) AssocLeft], 285 | [op "or" (BinOpE Or) AssocLeft]] 286 | where op s f assoc = Infix (do{ string s; spaces; return f}) assoc 287 | 288 | factor = between (char '(') (char ')' >> spaces) expr 289 | <|> field 290 | <|> literal 291 | "array length expression factor" 292 | 293 | field = skiptspaces $ fmap FieldE fieldname 294 | 295 | literal = skiptspaces $ fmap (LitE . read) $ many1 digit 296 | 297 | headerline = do { name <- many1 alphaNum; mb_params <- optionMaybe parameters; return (name, fromMaybe [] mb_params) } 298 | 299 | skiptspaces ma = do 300 | a <- ma 301 | spaces 302 | return a 303 | 304 | 305 | -- The real purpose of this is to fix up the types of the conditional expressions (0 may be used instead of False, etc) 306 | simplify :: [Field] -> [Field] 307 | simplify = map simplifyOne 308 | where simplifyOne f = f { field_type = fmapFieldExpr (simplifyFieldExpr True) (field_type f) } 309 | fmapFieldExpr f ty@(IfThenType { type_cond, type_then }) = ty { type_cond = f type_cond, type_then = fmapFieldExpr f type_then } 310 | fmapFieldExpr f ty@(IfThenElseType { type_cond, type_then, type_else }) = ty { type_cond = f type_cond, type_then = fmapFieldExpr f type_then, type_else = fmapFieldExpr f type_else } 311 | fmapFieldExpr _ ty = ty 312 | 313 | identifyComposites :: [Field] -> [Field] 314 | identifyComposites [] = [] 315 | identifyComposites (f:fs) 316 | 317 | | IfThenType cond typ <- field_type f 318 | , f <- f { field_type = typ } 319 | , (fs1, fs2) <- spanMaybe (\f' -> case field_type f' of IfThenType cond' typ' | cond' == cond -> Just (f' { field_type = typ' }); _ -> Nothing) fs 320 | , not (null fs1) 321 | , let field_names1 = map field_name $ f:fs1 322 | composite_typ = IfThenType cond $ CompositeType $ f : fs1 323 | composite_name = compositeName field_names1 324 | , all (\field_name1 -> S.notMember field_name1 (freeFields fs2)) field_names1 325 | = Field composite_name composite_typ "" Nothing : identifyComposites fs2 326 | 327 | | otherwise 328 | = f : identifyComposites fs 329 | 330 | 331 | compositeName :: [String] -> String 332 | compositeName names 333 | = case commonPrefix names `fallback` commonSuffix names of Just name -> name; Nothing -> error ("Nothing in common: " ++ show names) 334 | where 335 | commonPrefix :: Eq a => [[a]] -> Maybe [a] 336 | commonPrefix = go [] 337 | where go acc ((c:cs):css) 338 | | all ((== c) . head) css = Just $ fromMaybe (acc ++ [c]) $ go (acc ++ [c]) (cs:map tail css) 339 | | otherwise = Nothing 340 | 341 | commonSuffix = fmap reverse . commonPrefix . map reverse 342 | 343 | fallback mb1 mb2 = maybe mb2 Just mb1 344 | 345 | 346 | identifyExclusions :: [Field] -> [Field] 347 | identifyExclusions [] = [] 348 | identifyExclusions (f:fs) 349 | | any (`isInfixOf` field_name f) ["Reserved", "Padding"] 350 | = f { field_excluded = Just IsReserved } : identifyExclusions fs 351 | 352 | -- NB: we can only be said to control a field if the length count 353 | -- or condition is at the top level. If it is nested within another 354 | -- then when we write back we won't necessarily be able to materialise 355 | -- its value. 356 | 357 | -- However, it's totally OK to control more than one field. We can 358 | -- still extract a value in this case, and the consistency checks 359 | -- will ensure that everything is OK when writing back. 360 | 361 | | ((if_then, controls_field):_) 362 | <- [(if_then, other_f) 363 | | other_f <- fs 364 | , Just (if_then, FieldE cond_field_name) <- [type_cond_maybe (field_type other_f)] 365 | , cond_field_name == field_name f] 366 | = f { field_excluded = Just ((if if_then then IsPresenceFlag else IsSelectFlag) $ field_name controls_field) } : identifyExclusions fs 367 | 368 | | (controls_field:_) 369 | <- [other_f 370 | | other_f <- fs 371 | , RepeatType { type_type=typ, type_repeats=NumberOfTimes (FieldE len_field_name) } <- [field_type other_f] 372 | , len_field_name == field_name f] 373 | = f { field_excluded = Just (IsLength $ field_name controls_field) } : identifyExclusions fs 374 | 375 | | otherwise 376 | = f : identifyExclusions fs 377 | 378 | 379 | -- We can exclude fields if we can: 380 | -- At the time we need to bring the field into scope 381 | -- * Unconditionally produce some value for the field 382 | -- At later use sites 383 | -- * Check the consistency of the values inferred there with the one we assumed 384 | -- * This consistency check may be trivial (e.g. if the field was used 385 | -- in producing the initial value) 386 | 387 | 388 | recordToDecls :: Record -> (SpecialInfo, [Decl]) 389 | recordToDecls (Record { record_name, record_params, record_fields }) 390 | | (Field "Header" (TyConType (TyCon "RECORDHEADER" [])) comment Nothing):record_fields <- record_fields 391 | , let tag_type = read $ drop (length "Tag type = ") comment 392 | , (datacon, datacon_name, getter, getter_name, putter, putter_name) <- process record_fields 393 | = ((M.singleton Tag [(Int tag_type, getter_name, PRec datacon_name [PFieldWildcard], putter_name)], 394 | M.singleton Tag [datacon]), 395 | [getter, putter]) 396 | 397 | | (Field field_name (TyConType (TyCon "ACTIONRECORDHEADER" [])) comment Nothing):record_fields <- record_fields 398 | , field_name == record_name 399 | , [(action_code, _)] <- readHex $ drop (length "ActionCode = 0x") comment 400 | , (datacon, datacon_name, getter, getter_name, putter, putter_name) <- process record_fields 401 | = ((M.singleton Action [(Int action_code, getter_name, PRec datacon_name [PFieldWildcard], putter_name)], 402 | M.singleton Action [datacon]), 403 | [getter, putter]) 404 | 405 | | record_name `elem` ["STYLECHANGERECORD", "STRAIGHTEDGERECORD", "CURVEDEDGERECORD"] 406 | , (datacon, _, getter, _, putter, _) <- process record_fields 407 | = ((M.empty, M.singleton ShapeRecord [datacon]), 408 | [getter, putter]) 409 | 410 | | (datacon, _, getter, _, putter, _) <- process record_fields 411 | = ((M.empty, M.empty), 412 | [DataDecl noSrcLoc DataType [] (Ident record_name) [] [datacon] derivng, getter, putter]) 413 | where 414 | derivng = [(qname "Eq", []), (qname "Show", []), (qname "Typeable", []), (qname "Data", [])] 415 | 416 | process record_fields = (datacon, datacon_name, getter, UnQual getter_name, putter, UnQual putter_name) 417 | where 418 | datacon_name = qname record_name 419 | datacon = QualConDecl noSrcLoc [] [] (RecDecl (Ident record_name) recfields) 420 | recfields = [([bndr], UnBangedTy typ) | (bndr, typ) <- present_fields] 421 | 422 | defuser = defuseFieldName record_name 423 | params_bndrs = map (PVar . defuser) record_params 424 | 425 | getter_name = Ident $ "get" ++ record_name 426 | getter = FunBind [Match noSrcLoc getter_name params_bndrs Nothing (UnGuardedRhs getexpr) (BDecls [])] 427 | 428 | putter_name = Ident $ "put" ++ record_name 429 | putter = FunBind [Match noSrcLoc putter_name (params_bndrs ++ [PRec datacon_name [PFieldWildcard]]) Nothing (UnGuardedRhs (putexpr (ExpTypeSig noSrcLoc (var "x") (LHE.TyCon datacon_name)))) (BDecls [])] 430 | 431 | (present_fields, getexpr, putexpr) = fieldsToSyntax defuser how_accessed record_fields (\_ -> RecConstr (qname record_name) [FieldWildcard]) 432 | how_accessed hint mb_xs = map (fmap (\x -> App (Var $ UnQual $ x) hint)) mb_xs 433 | 434 | fieldsToSyntax :: (FieldName -> Name) -> (HintExp -> [Maybe Name] -> [Maybe HintExp]) -> [Field] -> ([Name] -> Exp) -> ([(Name, LHE.Type)], Exp, HintExp -> Exp) 435 | fieldsToSyntax defuser how_accessed fields finish 436 | = (present_fields, 437 | Do $ getter_stmts ++ [Qualifier $ App (var "return") $ finish (map fst present_fields)], 438 | \hint -> Do $ concat (map ($ hint) putter_stmtss) ++ [Qualifier $ App (var "return") (Tuple [])]) 439 | where 440 | present_fields = catMaybes mb_present_fields 441 | (mb_present_fields, getter_stmts, putter_stmtss) = unzip3 $ zipWith (\i field -> fieldToSyntax defuser (\hint -> how_accessed hint (map (fmap fst) mb_present_fields) !! i) field) [0..] fields 442 | 443 | fieldToSyntax :: (FieldName -> Name) -> (HintExp -> Maybe HintExp) -> Field -> (Maybe (Name, LHE.Type), Stmt, HintExp -> [Stmt]) 444 | fieldToSyntax defuser locate_hint field = case field_excluded field of 445 | Just we | IsReserved <- we -> (Nothing, Qualifier (discardReserved_ getexp), putter_stmts) 446 | | otherwise -> (Nothing, Generator noSrcLoc (PVar bndr) getexp, putter_stmts) 447 | where -- NB: the hint passed to the putter may be meaningful even though this 448 | -- is an excluded field, e.g. if its an excluded field that contains the 449 | -- the number of repititions in a list, and we overflow the maximum... 450 | (stmts, expr) = whyExcludedToSyntax defuser we 451 | putter_stmts hint = stmts ++ [LetStmt (BDecls [PatBind noSrcLoc (PVar bndr) Nothing (UnGuardedRhs expr) (BDecls [])]), 452 | Qualifier $ putexp (fromMaybe hint $ locate_hint hint) (Var (UnQual bndr))] 453 | Nothing -> (Just (bndr, ty), Generator noSrcLoc (PVar bndr) getexp, \hint -> [Qualifier $ putexp (fromMaybe hint $ locate_hint hint) (Var (UnQual bndr))]) 454 | where 455 | bndr = defuser (field_name field) 456 | (getexp, putexp, ty) = typeToSyntax defuser (field_type field) 457 | 458 | typeToSyntax :: (FieldName -> Name) -> Type -> (Exp, HintExp -> Exp -> Exp, LHE.Type) 459 | typeToSyntax defuser typ = case typ of 460 | TyConType (TyCon "PADDING8" []) 461 | -> (var "byteAlign", 462 | -- Rather nasty hack here to deal with PADDING8. If we don't provide the expression 463 | -- to "put" into this field with a type, GHC will complain about ambiguous type variables, 464 | -- but flushBits doesn't need any value at all. Solution: force it to have a particular type. 465 | \_ e -> App (App (var "const") (var "flushBits")) (ExpTypeSig noSrcLoc e $ TyTuple Boxed []), 466 | TyTuple Boxed []) 467 | 468 | TyConType (TyCon tycon args) 469 | -> (apps (var $ "get" ++ tycon) args_syns, 470 | \_ -> App $ apps (var $ "put" ++ tycon) args_syns, 471 | LHE.TyCon (qname tycon)) 472 | where args_syns = map (fieldExprToSyntax defuser) args 473 | 474 | TyConType (BitsTyCon UB (LitE 1)) 475 | -> (var "getFlag", 476 | \_ -> App $ var "putFlag", 477 | LHE.TyCon (qname "Bool")) 478 | 479 | TyConType (BitsTyCon btc lenexpr) 480 | -> (App (var $ "get" ++ show btc) lenexpr_syn, 481 | \hint e -> If (InfixApp (required_syn e) (qop "<=") lenexpr_syn) 482 | (App (App (var $ "put" ++ show btc) lenexpr_syn) e) 483 | (inconsistent_ hint (concat_ [str "Bit count incorrect: required ", show_ (required_syn e), str " bits to store the value ", show_ e, str ", but only have available ", show_ lenexpr_syn])), 484 | LHE.TyCon (qname $ show btc)) 485 | where lenexpr_syn = fieldExprToSyntax defuser lenexpr 486 | required_syn e = App (var $ "requiredBits" ++ show btc) e 487 | 488 | TupleType typs 489 | -> (lift_ (Con con : getters), 490 | \hint e -> caseTuple_ nelems e $ \xs -> Do $ zipWith3 (\i putter x -> Qualifier $ putter (nth_ i hint) (Var $ UnQual x)) [0..] putters xs, 491 | TyTuple Boxed tys) 492 | where (getters, putters, tys) = unzip3 $ map (typeToSyntax defuser) typs 493 | nelems = length typs 494 | lift_ = apps (var $ "liftM" ++ show nelems) 495 | con = qname $ "(" ++ replicate (nelems - 1) ',' ++ ")" 496 | 497 | CompositeType fields 498 | -> (getter, 499 | \hint e -> caseTupleKnownNames_ present_bndrs e (putter hint), 500 | TyTuple Boxed present_typs) 501 | where (present_bndrs, present_typs) = unzip present_fields 502 | (present_fields, getter, putter) = fieldsToSyntax defuser how_accessed fields (Tuple . map (Var . UnQual)) 503 | 504 | how_accessed hint mb_xs = map (fmap (\i -> nth_ i hint)) (match (map isJust mb_xs) [0..]) 505 | where 506 | match :: [Bool] -> [a] -> [Maybe a] 507 | match [] [] = [] 508 | match (True:fs) (x:xs) = Just x : match fs xs 509 | match (False:fs) xs = Nothing : match fs xs 510 | 511 | IfThenType condexpr typ 512 | -> (App (App (var "maybeHas") condexprsyn) getexp, 513 | \hint e -> caseMaybeGuarded_ e (checkConsistencyAltsTrue_ hint ("Should have a Just iff " ++ prettyExp condexprsyn ++ " is True") condexprsyn . putexp (App (var "fromJust") hint)) 514 | (checkConsistencyAltsFalse_ hint ("Should have a Nothing iff " ++ prettyExp condexprsyn ++ " is False") condexprsyn $ App (var "return") (Tuple [])), 515 | maybeTy_ ty) 516 | where condexprsyn = fieldExprToSyntax defuser condexpr 517 | (getexp, putexp, ty) = typeToSyntax defuser typ 518 | 519 | IfThenElseType condexpr typt typf 520 | -> (If condexprsyn (fmap_ (con "Left") getexpt) (fmap_ (con "Right") getexpf), 521 | \hint e -> caseEitherGuarded_ e (checkConsistencyAltsTrue_ hint ("Should have a Left iff " ++ prettyExp condexprsyn ++ " is True") condexprsyn . putexpt (App (var "fromLeft") hint)) 522 | (checkConsistencyAltsFalse_ hint ("Should have a Right iff " ++ prettyExp condexprsyn ++ " is False") condexprsyn . putexpf (App (var "fromRight") hint)), 523 | eitherTy_ tyt tyf) 524 | where condexprsyn = fieldExprToSyntax defuser condexpr 525 | (getexpt, putexpt, tyt) = typeToSyntax defuser typt 526 | (getexpf, putexpf, tyf) = typeToSyntax defuser typf 527 | 528 | RepeatType (TyConType (TyCon "BYTE" [])) RepeatsUntilEnd 529 | -> (var "getRemainingLazyByteString", 530 | \_ -> App $ var "putLazyByteString", 531 | LHE.TyCon (qname "ByteString")) 532 | 533 | RepeatType typ repeats -> case repeats of 534 | NumberOfTimes lenexpr 535 | -> (App (App (var "genericReplicateM") lenexprsyn) onegenexp, 536 | \hint e -> checkConsistency_ hint ("Mismatch with the required length: " ++ prettyExp lenexprsyn) (App (var "genericLength") e) lenexprsyn $ mapM__ (reifyLambda (oneputexp (hint `bangBang_` var "n"))) e, -- TODO: check consistency 537 | TyList onety) 538 | where lenexprsyn = fieldExprToSyntax defuser lenexpr 539 | OptionallyAtEnd 540 | -> (App (App (var "maybeHasM") (App (App (var "fmap") (var "not")) (var "isEmpty"))) onegenexp, 541 | \hint e -> caseMaybe_ e (oneputexp (fromMaybe_ hint)) (App (var "return") (Tuple [])), 542 | maybeTy_ onety) 543 | RepeatsUntilEnd 544 | -> (App (var "getToEnd") onegenexp, 545 | \hint -> mapM__ (reifyLambda $ oneputexp (hint `bangBang_` var "n")), 546 | TyList onety) 547 | where (onegenexp, oneputexp, onety) = typeToSyntax defuser typ 548 | 549 | whyExcludedToSyntax _ IsReserved = ([], var "reservedDefault") 550 | whyExcludedToSyntax defuser (IsPresenceFlag fn) = ([], App (var "isJust") (Var $ UnQual $ defuser fn)) 551 | whyExcludedToSyntax defuser (IsSelectFlag fn) = ([], App (var "isLeft") (Var $ UnQual $ defuser fn)) 552 | whyExcludedToSyntax defuser (IsLength fn) = ([], App (var "genericLength") (Var $ UnQual $ defuser fn)) 553 | whyExcludedToSyntax _ (HasCustomSynthesiser stmts e) = (stmts, e) 554 | 555 | fieldExprToSyntax _ (LitE i) = Lit (Int $ fromIntegral i) 556 | fieldExprToSyntax defuser (FieldE x) = Var $ UnQual $ defuser x -- TODO: this is blocking us using short names for non-stored fields, since we don't know what kind of name it will have 557 | fieldExprToSyntax defuser (UnOpE op e) = App eop (fieldExprToSyntax defuser e) 558 | where eop = case op of Not -> var "not" 559 | fieldExprToSyntax defuser (BinOpE op e1 e2) = InfixApp (fieldExprToSyntax defuser e1) (qop eop) (fieldExprToSyntax defuser e2) 560 | where eop = case op of Plus -> "+"; Mult -> "*"; Equals -> "=="; NotEquals -> "/="; And -> "&&"; Or -> "||" 561 | 562 | 563 | simplifyFieldExpr True (BinOpE Equals e1 (LitE 1)) = simplifyFieldExpr True e1 564 | simplifyFieldExpr True (BinOpE Equals e1 (LitE 0)) = UnOpE Not (simplifyFieldExpr True e1) 565 | simplifyFieldExpr True (BinOpE op e1 e2) = BinOpE op (simplifyFieldExpr e1ty e1) (simplifyFieldExpr e2ty e2) 566 | where (e1ty, e2ty) | op `elem` [And, Or] = (True, True) 567 | | otherwise = (False, False) 568 | simplifyFieldExpr True (UnOpE Not e) = UnOpE Not (simplifyFieldExpr True e) 569 | simplifyFieldExpr _ e = e 570 | 571 | 572 | type HintExp = Exp 573 | 574 | prettyExp :: Exp -> String 575 | prettyExp = LHEP.prettyPrintStyleMode (LHEP.style { LHEP.mode = LHEP.OneLineMode }) LHEP.defaultMode 576 | 577 | reifyHintExp :: HintExp -> Exp 578 | reifyHintExp = str . prettyExp 579 | 580 | inconsistent_ :: HintExp -> Exp -> Exp 581 | inconsistent_ hint what = App (App (var "inconsistent") (reifyHintExp hint)) what 582 | 583 | discardReserved_ :: Exp -> Exp 584 | discardReserved_ = App (App (var "discardReserved") (str "_reserved (x :: ?)")) -- TODO 585 | 586 | 587 | defuseFieldName record_name field_name = Ident $ toVarName record_name ++ '_':toVarName field_name 588 | where toVarName (c:s) = toLower c : s 589 | 590 | 591 | maybeTy_ = TyApp (LHE.TyCon (qname "Maybe")) 592 | eitherTy_ ty1 ty2 = TyApp (TyApp (LHE.TyCon (qname "Either")) ty1) ty2 593 | 594 | fmap_ efun efunctor = App (App (var "fmap") efun) efunctor 595 | mapM__ ef exs = App (App (var "mapM_") ef) exs 596 | bangBang_ e1 e2 = InfixApp e1 (qop "!!") e2 597 | fromMaybe_ = App (var "fromMaybe") 598 | concat_ = foldr1 append_ 599 | append_ e1 e2 = InfixApp e1 (qop "++") e2 600 | show_ = App (var "show") 601 | 602 | 603 | nth_ :: Integer -> Exp -> Exp 604 | nth_ n 605 | | n < genericLength nms = App (var (nms !! fromInteger n)) 606 | | otherwise = \e -> e `bangBang_` (Lit $ Int n) 607 | where nms = ["fst", "snd", "thd", "frth", "ffth", "sxth", "svnth"] 608 | 609 | reifyLambda oneputexp = Lambda noSrcLoc [PVar $ Ident "x"] (oneputexp $ var "x") 610 | 611 | checkConsistency_ hint why ehave ecomputed eresult 612 | = If (InfixApp ehave (qop "/=") (Paren ecomputed)) (inconsistent_ hint (concat_ [str why, show_ ehave, str " /= ", show_ ecomputed])) eresult 613 | 614 | checkConsistencyAltsTrue_ hint why ecomputed eresult 615 | = GuardedAlts [GuardedAlt noSrcLoc [Qualifier ecomputed] eresult, 616 | GuardedAlt noSrcLoc [Qualifier (var "otherwise")] (inconsistent_ hint (str why))] 617 | 618 | checkConsistencyAltsFalse_ hint why ecomputed eresult 619 | = GuardedAlts [GuardedAlt noSrcLoc [Qualifier ecomputed] (inconsistent_ hint (str why)), 620 | GuardedAlt noSrcLoc [Qualifier (var "otherwise")] eresult] 621 | 622 | caseMaybe_ e e_just e_nothing = caseMaybeGuarded_ e (UnGuardedAlt . e_just) (UnGuardedAlt e_nothing) 623 | 624 | caseMaybeGuarded_ e e_just e_nothing 625 | = Case e [Alt noSrcLoc (PApp (qname "Just") [PVar $ Ident "x"]) (e_just (var "x")) (BDecls []), 626 | Alt noSrcLoc (PApp (qname "Nothing") []) (e_nothing) (BDecls [])] 627 | 628 | caseEither_ e e_left e_right = caseEitherGuarded_ e (UnGuardedAlt . e_left) (UnGuardedAlt . e_right) 629 | 630 | caseEitherGuarded_ e e_left e_right 631 | = Case e [Alt noSrcLoc (PApp (qname "Left") [PVar $ Ident "x"]) (e_left (var "x")) (BDecls []), 632 | Alt noSrcLoc (PApp (qname "Right") [PVar $ Ident "x"]) (e_right (var "x")) (BDecls [])] 633 | 634 | caseTuple_ n e e_branch = caseTupleKnownNames_ xs e (e_branch xs) 635 | where xs = map (Ident . ("x" ++) . show) [1..n] 636 | 637 | caseTupleKnownNames_ xs e e_branch 638 | = Case e [Alt noSrcLoc (PTuple (map PVar xs)) (UnGuardedAlt e_branch) (BDecls [])] 639 | 640 | 641 | str = Lit . String 642 | var = Var . UnQual . Ident 643 | qname = UnQual . Ident 644 | qop = QVarOp . UnQual . Symbol 645 | con = Con . qname 646 | noSrcLoc = SrcLoc "" 0 0 647 | apps = foldl App 648 | 649 | 650 | spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) 651 | spanMaybe f = go 652 | where go [] = ([], []) 653 | go (x:xs) | Just y <- f x = first (y:) $ go xs 654 | | otherwise = ([], x:xs) 655 | -------------------------------------------------------------------------------- /examples/gnash/LICENSE: -------------------------------------------------------------------------------- 1 | The example SWF files in this directory were obtained from a checkout of the 2 | Gnash project (http://www.gnu.org/software/gnash/#downloading) on 6th February 3 | 2010. 4 | 5 | These examples *only* are distributed under the GPL v3 (reproduced below). For 6 | the avoidance of doubt, the SWF reading program ("hswf") that forms the principal 7 | part of this work does *not* fall under the GPL v3 license, but rather BSD3. 8 | 9 | 10 | GNU GENERAL PUBLIC LICENSE 11 | Version 3, 29 June 2007 12 | 13 | Copyright (C) 2007 Free Software Foundation, Inc. 14 | Everyone is permitted to copy and distribute verbatim copies 15 | of this license document, but changing it is not allowed. 16 | 17 | Preamble 18 | 19 | The GNU General Public License is a free, copyleft license for 20 | software and other kinds of works. 21 | 22 | The licenses for most software and other practical works are designed 23 | to take away your freedom to share and change the works. By contrast, 24 | the GNU General Public License is intended to guarantee your freedom to 25 | share and change all versions of a program--to make sure it remains free 26 | software for all its users. We, the Free Software Foundation, use the 27 | GNU General Public License for most of our software; it applies also to 28 | any other work released this way by its authors. You can apply it to 29 | your programs, too. 30 | 31 | When we speak of free software, we are referring to freedom, not 32 | price. Our General Public Licenses are designed to make sure that you 33 | have the freedom to distribute copies of free software (and charge for 34 | them if you wish), that you receive source code or can get it if you 35 | want it, that you can change the software or use pieces of it in new 36 | free programs, and that you know you can do these things. 37 | 38 | To protect your rights, we need to prevent others from denying you 39 | these rights or asking you to surrender the rights. Therefore, you have 40 | certain responsibilities if you distribute copies of the software, or if 41 | you modify it: responsibilities to respect the freedom of others. 42 | 43 | For example, if you distribute copies of such a program, whether 44 | gratis or for a fee, you must pass on to the recipients the same 45 | freedoms that you received. You must make sure that they, too, receive 46 | or can get the source code. And you must show them these terms so they 47 | know their rights. 48 | 49 | Developers that use the GNU GPL protect your rights with two steps: 50 | (1) assert copyright on the software, and (2) offer you this License 51 | giving you legal permission to copy, distribute and/or modify it. 52 | 53 | For the developers' and authors' protection, the GPL clearly explains 54 | that there is no warranty for this free software. For both users' and 55 | authors' sake, the GPL requires that modified versions be marked as 56 | changed, so that their problems will not be attributed erroneously to 57 | authors of previous versions. 58 | 59 | Some devices are designed to deny users access to install or run 60 | modified versions of the software inside them, although the manufacturer 61 | can do so. This is fundamentally incompatible with the aim of 62 | protecting users' freedom to change the software. The systematic 63 | pattern of such abuse occurs in the area of products for individuals to 64 | use, which is precisely where it is most unacceptable. Therefore, we 65 | have designed this version of the GPL to prohibit the practice for those 66 | products. If such problems arise substantially in other domains, we 67 | stand ready to extend this provision to those domains in future versions 68 | of the GPL, as needed to protect the freedom of users. 69 | 70 | Finally, every program is threatened constantly by software patents. 71 | States should not allow patents to restrict development and use of 72 | software on general-purpose computers, but in those that do, we wish to 73 | avoid the special danger that patents applied to a free program could 74 | make it effectively proprietary. To prevent this, the GPL assures that 75 | patents cannot be used to render the program non-free. 76 | 77 | The precise terms and conditions for copying, distribution and 78 | modification follow. 79 | 80 | TERMS AND CONDITIONS 81 | 82 | 0. Definitions. 83 | 84 | "This License" refers to version 3 of the GNU General Public License. 85 | 86 | "Copyright" also means copyright-like laws that apply to other kinds of 87 | works, such as semiconductor masks. 88 | 89 | "The Program" refers to any copyrightable work licensed under this 90 | License. Each licensee is addressed as "you". "Licensees" and 91 | "recipients" may be individuals or organizations. 92 | 93 | To "modify" a work means to copy from or adapt all or part of the work 94 | in a fashion requiring copyright permission, other than the making of an 95 | exact copy. The resulting work is called a "modified version" of the 96 | earlier work or a work "based on" the earlier work. 97 | 98 | A "covered work" means either the unmodified Program or a work based 99 | on the Program. 100 | 101 | To "propagate" a work means to do anything with it that, without 102 | permission, would make you directly or secondarily liable for 103 | infringement under applicable copyright law, except executing it on a 104 | computer or modifying a private copy. Propagation includes copying, 105 | distribution (with or without modification), making available to the 106 | public, and in some countries other activities as well. 107 | 108 | To "convey" a work means any kind of propagation that enables other 109 | parties to make or receive copies. Mere interaction with a user through 110 | a computer network, with no transfer of a copy, is not conveying. 111 | 112 | An interactive user interface displays "Appropriate Legal Notices" 113 | to the extent that it includes a convenient and prominently visible 114 | feature that (1) displays an appropriate copyright notice, and (2) 115 | tells the user that there is no warranty for the work (except to the 116 | extent that warranties are provided), that licensees may convey the 117 | work under this License, and how to view a copy of this License. If 118 | the interface presents a list of user commands or options, such as a 119 | menu, a prominent item in the list meets this criterion. 120 | 121 | 1. Source Code. 122 | 123 | The "source code" for a work means the preferred form of the work 124 | for making modifications to it. "Object code" means any non-source 125 | form of a work. 126 | 127 | A "Standard Interface" means an interface that either is an official 128 | standard defined by a recognized standards body, or, in the case of 129 | interfaces specified for a particular programming language, one that 130 | is widely used among developers working in that language. 131 | 132 | The "System Libraries" of an executable work include anything, other 133 | than the work as a whole, that (a) is included in the normal form of 134 | packaging a Major Component, but which is not part of that Major 135 | Component, and (b) serves only to enable use of the work with that 136 | Major Component, or to implement a Standard Interface for which an 137 | implementation is available to the public in source code form. A 138 | "Major Component", in this context, means a major essential component 139 | (kernel, window system, and so on) of the specific operating system 140 | (if any) on which the executable work runs, or a compiler used to 141 | produce the work, or an object code interpreter used to run it. 142 | 143 | The "Corresponding Source" for a work in object code form means all 144 | the source code needed to generate, install, and (for an executable 145 | work) run the object code and to modify the work, including scripts to 146 | control those activities. However, it does not include the work's 147 | System Libraries, or general-purpose tools or generally available free 148 | programs which are used unmodified in performing those activities but 149 | which are not part of the work. For example, Corresponding Source 150 | includes interface definition files associated with source files for 151 | the work, and the source code for shared libraries and dynamically 152 | linked subprograms that the work is specifically designed to require, 153 | such as by intimate data communication or control flow between those 154 | subprograms and other parts of the work. 155 | 156 | The Corresponding Source need not include anything that users 157 | can regenerate automatically from other parts of the Corresponding 158 | Source. 159 | 160 | The Corresponding Source for a work in source code form is that 161 | same work. 162 | 163 | 2. Basic Permissions. 164 | 165 | All rights granted under this License are granted for the term of 166 | copyright on the Program, and are irrevocable provided the stated 167 | conditions are met. This License explicitly affirms your unlimited 168 | permission to run the unmodified Program. The output from running a 169 | covered work is covered by this License only if the output, given its 170 | content, constitutes a covered work. This License acknowledges your 171 | rights of fair use or other equivalent, as provided by copyright law. 172 | 173 | You may make, run and propagate covered works that you do not 174 | convey, without conditions so long as your license otherwise remains 175 | in force. You may convey covered works to others for the sole purpose 176 | of having them make modifications exclusively for you, or provide you 177 | with facilities for running those works, provided that you comply with 178 | the terms of this License in conveying all material for which you do 179 | not control copyright. Those thus making or running the covered works 180 | for you must do so exclusively on your behalf, under your direction 181 | and control, on terms that prohibit them from making any copies of 182 | your copyrighted material outside their relationship with you. 183 | 184 | Conveying under any other circumstances is permitted solely under 185 | the conditions stated below. Sublicensing is not allowed; section 10 186 | makes it unnecessary. 187 | 188 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 189 | 190 | No covered work shall be deemed part of an effective technological 191 | measure under any applicable law fulfilling obligations under article 192 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 193 | similar laws prohibiting or restricting circumvention of such 194 | measures. 195 | 196 | When you convey a covered work, you waive any legal power to forbid 197 | circumvention of technological measures to the extent such circumvention 198 | is effected by exercising rights under this License with respect to 199 | the covered work, and you disclaim any intention to limit operation or 200 | modification of the work as a means of enforcing, against the work's 201 | users, your or third parties' legal rights to forbid circumvention of 202 | technological measures. 203 | 204 | 4. Conveying Verbatim Copies. 205 | 206 | You may convey verbatim copies of the Program's source code as you 207 | receive it, in any medium, provided that you conspicuously and 208 | appropriately publish on each copy an appropriate copyright notice; 209 | keep intact all notices stating that this License and any 210 | non-permissive terms added in accord with section 7 apply to the code; 211 | keep intact all notices of the absence of any warranty; and give all 212 | recipients a copy of this License along with the Program. 213 | 214 | You may charge any price or no price for each copy that you convey, 215 | and you may offer support or warranty protection for a fee. 216 | 217 | 5. Conveying Modified Source Versions. 218 | 219 | You may convey a work based on the Program, or the modifications to 220 | produce it from the Program, in the form of source code under the 221 | terms of section 4, provided that you also meet all of these conditions: 222 | 223 | a) The work must carry prominent notices stating that you modified 224 | it, and giving a relevant date. 225 | 226 | b) The work must carry prominent notices stating that it is 227 | released under this License and any conditions added under section 228 | 7. This requirement modifies the requirement in section 4 to 229 | "keep intact all notices". 230 | 231 | c) You must license the entire work, as a whole, under this 232 | License to anyone who comes into possession of a copy. This 233 | License will therefore apply, along with any applicable section 7 234 | additional terms, to the whole of the work, and all its parts, 235 | regardless of how they are packaged. This License gives no 236 | permission to license the work in any other way, but it does not 237 | invalidate such permission if you have separately received it. 238 | 239 | d) If the work has interactive user interfaces, each must display 240 | Appropriate Legal Notices; however, if the Program has interactive 241 | interfaces that do not display Appropriate Legal Notices, your 242 | work need not make them do so. 243 | 244 | A compilation of a covered work with other separate and independent 245 | works, which are not by their nature extensions of the covered work, 246 | and which are not combined with it such as to form a larger program, 247 | in or on a volume of a storage or distribution medium, is called an 248 | "aggregate" if the compilation and its resulting copyright are not 249 | used to limit the access or legal rights of the compilation's users 250 | beyond what the individual works permit. Inclusion of a covered work 251 | in an aggregate does not cause this License to apply to the other 252 | parts of the aggregate. 253 | 254 | 6. Conveying Non-Source Forms. 255 | 256 | You may convey a covered work in object code form under the terms 257 | of sections 4 and 5, provided that you also convey the 258 | machine-readable Corresponding Source under the terms of this License, 259 | in one of these ways: 260 | 261 | a) Convey the object code in, or embodied in, a physical product 262 | (including a physical distribution medium), accompanied by the 263 | Corresponding Source fixed on a durable physical medium 264 | customarily used for software interchange. 265 | 266 | b) Convey the object code in, or embodied in, a physical product 267 | (including a physical distribution medium), accompanied by a 268 | written offer, valid for at least three years and valid for as 269 | long as you offer spare parts or customer support for that product 270 | model, to give anyone who possesses the object code either (1) a 271 | copy of the Corresponding Source for all the software in the 272 | product that is covered by this License, on a durable physical 273 | medium customarily used for software interchange, for a price no 274 | more than your reasonable cost of physically performing this 275 | conveying of source, or (2) access to copy the 276 | Corresponding Source from a network server at no charge. 277 | 278 | c) Convey individual copies of the object code with a copy of the 279 | written offer to provide the Corresponding Source. This 280 | alternative is allowed only occasionally and noncommercially, and 281 | only if you received the object code with such an offer, in accord 282 | with subsection 6b. 283 | 284 | d) Convey the object code by offering access from a designated 285 | place (gratis or for a charge), and offer equivalent access to the 286 | Corresponding Source in the same way through the same place at no 287 | further charge. You need not require recipients to copy the 288 | Corresponding Source along with the object code. If the place to 289 | copy the object code is a network server, the Corresponding Source 290 | may be on a different server (operated by you or a third party) 291 | that supports equivalent copying facilities, provided you maintain 292 | clear directions next to the object code saying where to find the 293 | Corresponding Source. Regardless of what server hosts the 294 | Corresponding Source, you remain obligated to ensure that it is 295 | available for as long as needed to satisfy these requirements. 296 | 297 | e) Convey the object code using peer-to-peer transmission, provided 298 | you inform other peers where the object code and Corresponding 299 | Source of the work are being offered to the general public at no 300 | charge under subsection 6d. 301 | 302 | A separable portion of the object code, whose source code is excluded 303 | from the Corresponding Source as a System Library, need not be 304 | included in conveying the object code work. 305 | 306 | A "User Product" is either (1) a "consumer product", which means any 307 | tangible personal property which is normally used for personal, family, 308 | or household purposes, or (2) anything designed or sold for incorporation 309 | into a dwelling. In determining whether a product is a consumer product, 310 | doubtful cases shall be resolved in favor of coverage. For a particular 311 | product received by a particular user, "normally used" refers to a 312 | typical or common use of that class of product, regardless of the status 313 | of the particular user or of the way in which the particular user 314 | actually uses, or expects or is expected to use, the product. A product 315 | is a consumer product regardless of whether the product has substantial 316 | commercial, industrial or non-consumer uses, unless such uses represent 317 | the only significant mode of use of the product. 318 | 319 | "Installation Information" for a User Product means any methods, 320 | procedures, authorization keys, or other information required to install 321 | and execute modified versions of a covered work in that User Product from 322 | a modified version of its Corresponding Source. The information must 323 | suffice to ensure that the continued functioning of the modified object 324 | code is in no case prevented or interfered with solely because 325 | modification has been made. 326 | 327 | If you convey an object code work under this section in, or with, or 328 | specifically for use in, a User Product, and the conveying occurs as 329 | part of a transaction in which the right of possession and use of the 330 | User Product is transferred to the recipient in perpetuity or for a 331 | fixed term (regardless of how the transaction is characterized), the 332 | Corresponding Source conveyed under this section must be accompanied 333 | by the Installation Information. But this requirement does not apply 334 | if neither you nor any third party retains the ability to install 335 | modified object code on the User Product (for example, the work has 336 | been installed in ROM). 337 | 338 | The requirement to provide Installation Information does not include a 339 | requirement to continue to provide support service, warranty, or updates 340 | for a work that has been modified or installed by the recipient, or for 341 | the User Product in which it has been modified or installed. Access to a 342 | network may be denied when the modification itself materially and 343 | adversely affects the operation of the network or violates the rules and 344 | protocols for communication across the network. 345 | 346 | Corresponding Source conveyed, and Installation Information provided, 347 | in accord with this section must be in a format that is publicly 348 | documented (and with an implementation available to the public in 349 | source code form), and must require no special password or key for 350 | unpacking, reading or copying. 351 | 352 | 7. Additional Terms. 353 | 354 | "Additional permissions" are terms that supplement the terms of this 355 | License by making exceptions from one or more of its conditions. 356 | Additional permissions that are applicable to the entire Program shall 357 | be treated as though they were included in this License, to the extent 358 | that they are valid under applicable law. If additional permissions 359 | apply only to part of the Program, that part may be used separately 360 | under those permissions, but the entire Program remains governed by 361 | this License without regard to the additional permissions. 362 | 363 | When you convey a copy of a covered work, you may at your option 364 | remove any additional permissions from that copy, or from any part of 365 | it. (Additional permissions may be written to require their own 366 | removal in certain cases when you modify the work.) You may place 367 | additional permissions on material, added by you to a covered work, 368 | for which you have or can give appropriate copyright permission. 369 | 370 | Notwithstanding any other provision of this License, for material you 371 | add to a covered work, you may (if authorized by the copyright holders of 372 | that material) supplement the terms of this License with terms: 373 | 374 | a) Disclaiming warranty or limiting liability differently from the 375 | terms of sections 15 and 16 of this License; or 376 | 377 | b) Requiring preservation of specified reasonable legal notices or 378 | author attributions in that material or in the Appropriate Legal 379 | Notices displayed by works containing it; or 380 | 381 | c) Prohibiting misrepresentation of the origin of that material, or 382 | requiring that modified versions of such material be marked in 383 | reasonable ways as different from the original version; or 384 | 385 | d) Limiting the use for publicity purposes of names of licensors or 386 | authors of the material; or 387 | 388 | e) Declining to grant rights under trademark law for use of some 389 | trade names, trademarks, or service marks; or 390 | 391 | f) Requiring indemnification of licensors and authors of that 392 | material by anyone who conveys the material (or modified versions of 393 | it) with contractual assumptions of liability to the recipient, for 394 | any liability that these contractual assumptions directly impose on 395 | those licensors and authors. 396 | 397 | All other non-permissive additional terms are considered "further 398 | restrictions" within the meaning of section 10. If the Program as you 399 | received it, or any part of it, contains a notice stating that it is 400 | governed by this License along with a term that is a further 401 | restriction, you may remove that term. If a license document contains 402 | a further restriction but permits relicensing or conveying under this 403 | License, you may add to a covered work material governed by the terms 404 | of that license document, provided that the further restriction does 405 | not survive such relicensing or conveying. 406 | 407 | If you add terms to a covered work in accord with this section, you 408 | must place, in the relevant source files, a statement of the 409 | additional terms that apply to those files, or a notice indicating 410 | where to find the applicable terms. 411 | 412 | Additional terms, permissive or non-permissive, may be stated in the 413 | form of a separately written license, or stated as exceptions; 414 | the above requirements apply either way. 415 | 416 | 8. Termination. 417 | 418 | You may not propagate or modify a covered work except as expressly 419 | provided under this License. Any attempt otherwise to propagate or 420 | modify it is void, and will automatically terminate your rights under 421 | this License (including any patent licenses granted under the third 422 | paragraph of section 11). 423 | 424 | However, if you cease all violation of this License, then your 425 | license from a particular copyright holder is reinstated (a) 426 | provisionally, unless and until the copyright holder explicitly and 427 | finally terminates your license, and (b) permanently, if the copyright 428 | holder fails to notify you of the violation by some reasonable means 429 | prior to 60 days after the cessation. 430 | 431 | Moreover, your license from a particular copyright holder is 432 | reinstated permanently if the copyright holder notifies you of the 433 | violation by some reasonable means, this is the first time you have 434 | received notice of violation of this License (for any work) from that 435 | copyright holder, and you cure the violation prior to 30 days after 436 | your receipt of the notice. 437 | 438 | Termination of your rights under this section does not terminate the 439 | licenses of parties who have received copies or rights from you under 440 | this License. If your rights have been terminated and not permanently 441 | reinstated, you do not qualify to receive new licenses for the same 442 | material under section 10. 443 | 444 | 9. Acceptance Not Required for Having Copies. 445 | 446 | You are not required to accept this License in order to receive or 447 | run a copy of the Program. Ancillary propagation of a covered work 448 | occurring solely as a consequence of using peer-to-peer transmission 449 | to receive a copy likewise does not require acceptance. However, 450 | nothing other than this License grants you permission to propagate or 451 | modify any covered work. These actions infringe copyright if you do 452 | not accept this License. Therefore, by modifying or propagating a 453 | covered work, you indicate your acceptance of this License to do so. 454 | 455 | 10. Automatic Licensing of Downstream Recipients. 456 | 457 | Each time you convey a covered work, the recipient automatically 458 | receives a license from the original licensors, to run, modify and 459 | propagate that work, subject to this License. You are not responsible 460 | for enforcing compliance by third parties with this License. 461 | 462 | An "entity transaction" is a transaction transferring control of an 463 | organization, or substantially all assets of one, or subdividing an 464 | organization, or merging organizations. If propagation of a covered 465 | work results from an entity transaction, each party to that 466 | transaction who receives a copy of the work also receives whatever 467 | licenses to the work the party's predecessor in interest had or could 468 | give under the previous paragraph, plus a right to possession of the 469 | Corresponding Source of the work from the predecessor in interest, if 470 | the predecessor has it or can get it with reasonable efforts. 471 | 472 | You may not impose any further restrictions on the exercise of the 473 | rights granted or affirmed under this License. For example, you may 474 | not impose a license fee, royalty, or other charge for exercise of 475 | rights granted under this License, and you may not initiate litigation 476 | (including a cross-claim or counterclaim in a lawsuit) alleging that 477 | any patent claim is infringed by making, using, selling, offering for 478 | sale, or importing the Program or any portion of it. 479 | 480 | 11. Patents. 481 | 482 | A "contributor" is a copyright holder who authorizes use under this 483 | License of the Program or a work on which the Program is based. The 484 | work thus licensed is called the contributor's "contributor version". 485 | 486 | A contributor's "essential patent claims" are all patent claims 487 | owned or controlled by the contributor, whether already acquired or 488 | hereafter acquired, that would be infringed by some manner, permitted 489 | by this License, of making, using, or selling its contributor version, 490 | but do not include claims that would be infringed only as a 491 | consequence of further modification of the contributor version. For 492 | purposes of this definition, "control" includes the right to grant 493 | patent sublicenses in a manner consistent with the requirements of 494 | this License. 495 | 496 | Each contributor grants you a non-exclusive, worldwide, royalty-free 497 | patent license under the contributor's essential patent claims, to 498 | make, use, sell, offer for sale, import and otherwise run, modify and 499 | propagate the contents of its contributor version. 500 | 501 | In the following three paragraphs, a "patent license" is any express 502 | agreement or commitment, however denominated, not to enforce a patent 503 | (such as an express permission to practice a patent or covenant not to 504 | sue for patent infringement). To "grant" such a patent license to a 505 | party means to make such an agreement or commitment not to enforce a 506 | patent against the party. 507 | 508 | If you convey a covered work, knowingly relying on a patent license, 509 | and the Corresponding Source of the work is not available for anyone 510 | to copy, free of charge and under the terms of this License, through a 511 | publicly available network server or other readily accessible means, 512 | then you must either (1) cause the Corresponding Source to be so 513 | available, or (2) arrange to deprive yourself of the benefit of the 514 | patent license for this particular work, or (3) arrange, in a manner 515 | consistent with the requirements of this License, to extend the patent 516 | license to downstream recipients. "Knowingly relying" means you have 517 | actual knowledge that, but for the patent license, your conveying the 518 | covered work in a country, or your recipient's use of the covered work 519 | in a country, would infringe one or more identifiable patents in that 520 | country that you have reason to believe are valid. 521 | 522 | If, pursuant to or in connection with a single transaction or 523 | arrangement, you convey, or propagate by procuring conveyance of, a 524 | covered work, and grant a patent license to some of the parties 525 | receiving the covered work authorizing them to use, propagate, modify 526 | or convey a specific copy of the covered work, then the patent license 527 | you grant is automatically extended to all recipients of the covered 528 | work and works based on it. 529 | 530 | A patent license is "discriminatory" if it does not include within 531 | the scope of its coverage, prohibits the exercise of, or is 532 | conditioned on the non-exercise of one or more of the rights that are 533 | specifically granted under this License. You may not convey a covered 534 | work if you are a party to an arrangement with a third party that is 535 | in the business of distributing software, under which you make payment 536 | to the third party based on the extent of your activity of conveying 537 | the work, and under which the third party grants, to any of the 538 | parties who would receive the covered work from you, a discriminatory 539 | patent license (a) in connection with copies of the covered work 540 | conveyed by you (or copies made from those copies), or (b) primarily 541 | for and in connection with specific products or compilations that 542 | contain the covered work, unless you entered into that arrangement, 543 | or that patent license was granted, prior to 28 March 2007. 544 | 545 | Nothing in this License shall be construed as excluding or limiting 546 | any implied license or other defenses to infringement that may 547 | otherwise be available to you under applicable patent law. 548 | 549 | 12. No Surrender of Others' Freedom. 550 | 551 | If conditions are imposed on you (whether by court order, agreement or 552 | otherwise) that contradict the conditions of this License, they do not 553 | excuse you from the conditions of this License. If you cannot convey a 554 | covered work so as to satisfy simultaneously your obligations under this 555 | License and any other pertinent obligations, then as a consequence you may 556 | not convey it at all. For example, if you agree to terms that obligate you 557 | to collect a royalty for further conveying from those to whom you convey 558 | the Program, the only way you could satisfy both those terms and this 559 | License would be to refrain entirely from conveying the Program. 560 | 561 | 13. Use with the GNU Affero General Public License. 562 | 563 | Notwithstanding any other provision of this License, you have 564 | permission to link or combine any covered work with a work licensed 565 | under version 3 of the GNU Affero General Public License into a single 566 | combined work, and to convey the resulting work. The terms of this 567 | License will continue to apply to the part which is the covered work, 568 | but the special requirements of the GNU Affero General Public License, 569 | section 13, concerning interaction through a network will apply to the 570 | combination as such. 571 | 572 | 14. Revised Versions of this License. 573 | 574 | The Free Software Foundation may publish revised and/or new versions of 575 | the GNU General Public License from time to time. Such new versions will 576 | be similar in spirit to the present version, but may differ in detail to 577 | address new problems or concerns. 578 | 579 | Each version is given a distinguishing version number. If the 580 | Program specifies that a certain numbered version of the GNU General 581 | Public License "or any later version" applies to it, you have the 582 | option of following the terms and conditions either of that numbered 583 | version or of any later version published by the Free Software 584 | Foundation. If the Program does not specify a version number of the 585 | GNU General Public License, you may choose any version ever published 586 | by the Free Software Foundation. 587 | 588 | If the Program specifies that a proxy can decide which future 589 | versions of the GNU General Public License can be used, that proxy's 590 | public statement of acceptance of a version permanently authorizes you 591 | to choose that version for the Program. 592 | 593 | Later license versions may give you additional or different 594 | permissions. However, no additional obligations are imposed on any 595 | author or copyright holder as a result of your choosing to follow a 596 | later version. 597 | 598 | 15. Disclaimer of Warranty. 599 | 600 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 601 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 602 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 603 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 604 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 605 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 606 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 607 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 608 | 609 | 16. Limitation of Liability. 610 | 611 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 612 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 613 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 614 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 615 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 616 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 617 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 618 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 619 | SUCH DAMAGES. 620 | 621 | 17. Interpretation of Sections 15 and 16. 622 | 623 | If the disclaimer of warranty and limitation of liability provided 624 | above cannot be given local legal effect according to their terms, 625 | reviewing courts shall apply local law that most closely approximates 626 | an absolute waiver of all civil liability in connection with the 627 | Program, unless a warranty or assumption of liability accompanies a 628 | copy of the Program in return for a fee. 629 | 630 | END OF TERMS AND CONDITIONS 631 | 632 | How to Apply These Terms to Your New Programs 633 | 634 | If you develop a new program, and you want it to be of the greatest 635 | possible use to the public, the best way to achieve this is to make it 636 | free software which everyone can redistribute and change under these terms. 637 | 638 | To do so, attach the following notices to the program. It is safest 639 | to attach them to the start of each source file to most effectively 640 | state the exclusion of warranty; and each file should have at least 641 | the "copyright" line and a pointer to where the full notice is found. 642 | 643 | 644 | Copyright (C) 645 | 646 | This program is free software: you can redistribute it and/or modify 647 | it under the terms of the GNU General Public License as published by 648 | the Free Software Foundation, either version 3 of the License, or 649 | (at your option) any later version. 650 | 651 | This program is distributed in the hope that it will be useful, 652 | but WITHOUT ANY WARRANTY; without even the implied warranty of 653 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 654 | GNU General Public License for more details. 655 | 656 | You should have received a copy of the GNU General Public License 657 | along with this program. If not, see . 658 | 659 | Also add information on how to contact you by electronic and paper mail. 660 | 661 | If the program does terminal interaction, make it output a short 662 | notice like this when it starts in an interactive mode: 663 | 664 | Copyright (C) 665 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 666 | This is free software, and you are welcome to redistribute it 667 | under certain conditions; type `show c' for details. 668 | 669 | The hypothetical commands `show w' and `show c' should show the appropriate 670 | parts of the General Public License. Of course, your program's commands 671 | might be different; for a GUI interface, you would use an "about box". 672 | 673 | You should also get your employer (if you work as a programmer) or school, 674 | if any, to sign a "copyright disclaimer" for the program, if necessary. 675 | For more information on this, and how to apply and follow the GNU GPL, see 676 | . 677 | 678 | The GNU General Public License does not permit incorporating your program 679 | into proprietary programs. If your program is a subroutine library, you 680 | may consider it more useful to permit linking proprietary applications with 681 | the library. If this is what you want to do, use the GNU Lesser General 682 | Public License instead of this License. But first, please read 683 | . 684 | 685 | --------------------------------------------------------------------------------