summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBerniePope <>2013-04-18 01:46:27 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-04-18 01:46:27 (GMT)
commit70f3d6f936b65e6cbe9ff8e3cddfe98946caa09b (patch)
tree649062be7dcd7e9534af464eea9b67c3b1872cc3
version 0.1.00.1.0
-rw-r--r--LICENSE30
-rw-r--r--Setup.lhs3
-rw-r--r--bliplib.cabal38
-rw-r--r--src/Blip/Bytecode.hs341
-rw-r--r--src/Blip/Marshal.hs391
-rw-r--r--src/Blip/MarshalDouble.hs42
-rw-r--r--src/Blip/Pretty.hs84
-rw-r--r--src/Blip/Version.hs19
8 files changed, 948 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..a87a16f
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Bernard Pope 2012, 2013
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Bernard Pope nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..5bde0de
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/bliplib.cabal b/bliplib.cabal
new file mode 100644
index 0000000..d560f2b
--- /dev/null
+++ b/bliplib.cabal
@@ -0,0 +1,38 @@
+Name: bliplib
+Version: 0.1.0
+Synopsis: Support code for Blip.
+Homepage: https://github.com/bjpop/blip
+License: BSD3
+License-file: LICENSE
+Author: Bernie Pope
+Maintainer: Bernie Pope <florbitous@gmail.com>
+Stability: Experimental
+category: Development
+Build-type: Simple
+Cabal-version: >=1.8
+Description: Support code for the Blip compiler. In particular, a library for reading, writing and manipulating Python 3 bytecode files.
+
+source-repository head
+ type: git
+ location: git://github.com/bjpop/blip.git
+
+Library {
+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-orphans
+ hs-source-dirs: src
+ exposed-modules:
+ Blip.Bytecode,
+ Blip.Marshal,
+ Blip.MarshalDouble,
+ Blip.Pretty,
+ Blip.Version
+ build-depends:
+ base==4.*,
+ binary==0.7.*,
+ mtl==2.1.*,
+ containers==0.5.*,
+ pretty==1.1.*,
+ bytestring==0.10.*,
+ utf8-string==0.3.*
+ other-modules:
+ Paths_bliplib
+}
diff --git a/src/Blip/Bytecode.hs b/src/Blip/Bytecode.hs
new file mode 100644
index 0000000..2ea2068
--- /dev/null
+++ b/src/Blip/Bytecode.hs
@@ -0,0 +1,341 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Blip.Bytecode
+-- Copyright : (c) 2012, 2013 Bernie Pope
+-- License : BSD-style
+-- Maintainer : florbitous@gmail.com
+-- Stability : experimental
+-- Portability : ghc
+--
+-- Python 3 bytecode.
+--
+-----------------------------------------------------------------------------
+module Blip.Bytecode
+ ( decode, encode, Opcode (..), Bytecode (..),
+ BytecodeArg (..), BytecodeSeq (..), bytecodeSize ) where
+
+import Data.Word (Word8, Word16)
+import Data.ByteString.Lazy as B
+ ( ByteString, unpack, pack )
+import Data.Map as Map hiding (map)
+import Data.Bits ((.&.), shiftL, shiftR)
+import Text.PrettyPrint
+ ( text, (<+>), Doc, int, vcat )
+import Blip.Pretty (Pretty (..))
+
+data Opcode
+ = POP_TOP -- 1
+ | ROT_TWO -- 2
+ | ROT_THREE -- 3
+ | DUP_TOP -- 4
+ | DUP_TOP_TWO -- 5
+ | NOP -- 9
+ | UNARY_POSITIVE -- 10
+ | UNARY_NEGATIVE -- 11
+ | UNARY_NOT -- 12
+ | UNARY_INVERT -- 15
+ | BINARY_POWER -- 19
+ | BINARY_MULTIPLY -- 20
+ | BINARY_MODULO -- 22
+ | BINARY_ADD -- 23
+ | BINARY_SUBTRACT -- 24
+ | BINARY_SUBSCR -- 25
+ | BINARY_FLOOR_DIVIDE -- 26
+ | BINARY_TRUE_DIVIDE -- 27
+ | INPLACE_FLOOR_DIVIDE -- 28
+ | INPLACE_TRUE_DIVIDE -- 29
+ | STORE_MAP -- 54
+ | INPLACE_ADD -- 55
+ | INPLACE_SUBTRACT -- 56
+ | INPLACE_MULTIPLY -- 57
+ | INPLACE_MODULO -- 59
+ | STORE_SUBSCR -- 60
+ | DELETE_SUBSCR -- 61
+ | BINARY_LSHIFT -- 62
+ | BINARY_RSHIFT -- 63
+ | BINARY_AND -- 64
+ | BINARY_XOR -- 65
+ | BINARY_OR -- 66
+ | INPLACE_POWER -- 67
+ | GET_ITER -- 68
+ | STORE_LOCALS -- 69
+ | PRINT_EXPR -- 70
+ | LOAD_BUILD_CLASS -- 71
+ | YIELD_FROM -- 72
+ | INPLACE_LSHIFT -- 75
+ | INPLACE_RSHIFT -- 76
+ | INPLACE_AND -- 77
+ | INPLACE_XOR -- 78
+ | INPLACE_OR -- 79
+ | BREAK_LOOP -- 80
+ | WITH_CLEANUP -- 81
+ | RETURN_VALUE -- 83
+ | IMPORT_STAR -- 84
+ | YIELD_VALUE -- 86
+ | POP_BLOCK -- 87
+ | END_FINALLY -- 88
+ | POP_EXCEPT -- 89
+ -- | HAVE_ARGUMENT -- 90 Opcodes from here have an argument:
+ | STORE_NAME -- 90 Index in name list
+ | DELETE_NAME -- 91 ""
+ | UNPACK_SEQUENCE -- 92 Number of sequence items
+ | FOR_ITER -- 93
+ | UNPACK_EX -- 94 Num items before variable part + (Num items after variable part << 8)
+ | STORE_ATTR -- 95 Index in name list
+ | DELETE_ATTR -- 96 ""
+ | STORE_GLOBAL -- 97 ""
+ | DELETE_GLOBAL -- 98 ""
+ | LOAD_CONST -- 100 Index in const list
+ | LOAD_NAME -- 101 Index in name list
+ | BUILD_TUPLE -- 102 Number of tuple items
+ | BUILD_LIST -- 103 Number of list items
+ | BUILD_SET -- 104 Number of set items
+ | BUILD_MAP -- 105 Always zero for now
+ | LOAD_ATTR -- 106 Index in name list
+ | COMPARE_OP -- 107 Comparison operator
+ | IMPORT_NAME -- 108 Index in name list
+ | IMPORT_FROM -- 109 Index in name list
+ | JUMP_FORWARD -- 110 Number of bytes to skip
+ | JUMP_IF_FALSE_OR_POP -- 111 Target byte offset from beginning of code
+ | JUMP_IF_TRUE_OR_POP -- 112 ""
+ | JUMP_ABSOLUTE -- 113 ""
+ | POP_JUMP_IF_FALSE -- 114 ""
+ | POP_JUMP_IF_TRUE -- 115 ""
+ | LOAD_GLOBAL -- 116 Index in name list
+ | CONTINUE_LOOP -- 119 Start of loop (absolute)
+ | SETUP_LOOP -- 120 Target address (relative)
+ | SETUP_EXCEPT -- 121 ""
+ | SETUP_FINALLY -- 122 ""
+ | LOAD_FAST -- 124 Local variable number
+ | STORE_FAST -- 125 Local variable number
+ | DELETE_FAST -- 126 Local variable number
+ | RAISE_VARARGS -- 130 Number of raise arguments (1, 2 or 3)
+ | CALL_FUNCTION -- 131 #args + (#kwargs<<8) CALL_FUNCTION_XXX opcodes defined below depend on this definition
+ | MAKE_FUNCTION -- 132 #defaults + #kwdefaults<<8 + #annotations<<16
+ | BUILD_SLICE -- 133 Number of items
+ | MAKE_CLOSURE -- 134 same as MAKE_FUNCTION
+ | LOAD_CLOSURE -- 135 Load free variable from closure
+ | LOAD_DEREF -- 136 Load and dereference from closure cell
+ | STORE_DEREF -- 137 Store into cell
+ | DELETE_DEREF -- 138 Delete closure cell
+
+ {- The next 3 opcodes must be contiguous and satisfy
+ (CALL_FUNCTION_VAR - CALL_FUNCTION) & 3 == 1 -}
+
+ | CALL_FUNCTION_VAR -- 140 #args + (#kwargs<<8)
+ | CALL_FUNCTION_KW -- 141 #args + (#kwargs<<8)
+ | CALL_FUNCTION_VAR_KW -- 142 #args + (#kwargs<<8)
+
+ | SETUP_WITH -- 143
+ | EXTENDED_ARG -- 144 Support for opargs more than 16 bits long
+ | LIST_APPEND -- 145
+ | SET_ADD -- 146
+ | MAP_ADD -- 147
+
+ {- EXCEPT_HANDLER is a special, implicit block type which is created when
+ entering an except handler. It is not an opcode but we define it here
+ as we want it to be available to both frameobject.c and ceval.c, while
+ remaining private. -}
+
+ {- EXCEPT_HANDLER -- 257 -}
+ deriving (Eq, Ord, Show)
+
+opcodeToWord8 :: Map.Map Opcode Word8
+opcodeToWord8 = Map.fromList opcodeList
+
+word8ToOpcode :: Map.Map Word8 Opcode
+word8ToOpcode = Map.fromList [ (y, x) | (x, y) <- opcodeList ]
+
+opcodeList :: [(Opcode, Word8)]
+opcodeList = [
+ (POP_TOP, 1),
+ (ROT_TWO, 2),
+ (ROT_THREE, 3),
+ (DUP_TOP, 4),
+ (DUP_TOP_TWO, 5),
+ (NOP, 9),
+ (UNARY_POSITIVE, 10),
+ (UNARY_NEGATIVE, 11),
+ (UNARY_NOT, 12),
+ (UNARY_INVERT, 15),
+ (BINARY_POWER, 19),
+ (BINARY_MULTIPLY, 20),
+ (BINARY_MODULO, 22),
+ (BINARY_ADD, 23),
+ (BINARY_SUBTRACT, 24),
+ (BINARY_SUBSCR, 25),
+ (BINARY_FLOOR_DIVIDE, 26),
+ (BINARY_TRUE_DIVIDE, 27),
+ (INPLACE_FLOOR_DIVIDE, 28),
+ (INPLACE_TRUE_DIVIDE, 29),
+ (STORE_MAP, 54),
+ (INPLACE_ADD, 55),
+ (INPLACE_SUBTRACT, 56),
+ (INPLACE_MULTIPLY, 57),
+ (INPLACE_MODULO, 59),
+ (STORE_SUBSCR, 60),
+ (DELETE_SUBSCR, 61),
+ (BINARY_LSHIFT, 62),
+ (BINARY_RSHIFT, 63),
+ (BINARY_AND, 64),
+ (BINARY_XOR, 65),
+ (BINARY_OR, 66),
+ (INPLACE_POWER, 67),
+ (GET_ITER, 68),
+ (STORE_LOCALS, 69),
+ (PRINT_EXPR, 70),
+ (LOAD_BUILD_CLASS, 71),
+ (YIELD_FROM, 72),
+ (INPLACE_LSHIFT, 75),
+ (INPLACE_RSHIFT, 76),
+ (INPLACE_AND, 77),
+ (INPLACE_XOR, 78),
+ (INPLACE_OR, 79),
+ (BREAK_LOOP, 80),
+ (WITH_CLEANUP, 81),
+ (RETURN_VALUE, 83),
+ (IMPORT_STAR, 84),
+ (YIELD_VALUE, 86),
+ (POP_BLOCK, 87),
+ (END_FINALLY, 88),
+ (POP_EXCEPT, 89),
+ -- (HAVE_ARGUMENT, 90),
+ (STORE_NAME, 90),
+ (DELETE_NAME, 91),
+ (UNPACK_SEQUENCE, 92),
+ (FOR_ITER, 93),
+ (UNPACK_EX, 94),
+ (STORE_ATTR, 95),
+ (DELETE_ATTR, 96),
+ (STORE_GLOBAL, 97),
+ (DELETE_GLOBAL, 98),
+ (LOAD_CONST, 100),
+ (LOAD_NAME, 101),
+ (BUILD_TUPLE, 102),
+ (BUILD_LIST, 103),
+ (BUILD_SET, 104),
+ (BUILD_MAP, 105),
+ (LOAD_ATTR, 106),
+ (COMPARE_OP, 107),
+ (IMPORT_NAME, 108),
+ (IMPORT_FROM, 109),
+ (JUMP_FORWARD, 110),
+ (JUMP_IF_FALSE_OR_POP, 111),
+ (JUMP_IF_TRUE_OR_POP, 112),
+ (JUMP_ABSOLUTE, 113),
+ (POP_JUMP_IF_FALSE, 114),
+ (POP_JUMP_IF_TRUE, 115),
+ (LOAD_GLOBAL, 116),
+ (CONTINUE_LOOP, 119),
+ (SETUP_LOOP, 120),
+ (SETUP_EXCEPT, 121),
+ (SETUP_FINALLY, 122),
+ (LOAD_FAST, 124),
+ (STORE_FAST, 125),
+ (DELETE_FAST, 126),
+ (RAISE_VARARGS, 130),
+ (CALL_FUNCTION, 131),
+ (MAKE_FUNCTION, 132),
+ (BUILD_SLICE, 133),
+ (MAKE_CLOSURE, 134),
+ (LOAD_CLOSURE, 135),
+ (LOAD_DEREF, 136),
+ (STORE_DEREF, 137),
+ (DELETE_DEREF, 138),
+ (CALL_FUNCTION_VAR, 140),
+ (CALL_FUNCTION_KW, 141),
+ (CALL_FUNCTION_VAR_KW, 142),
+ (SETUP_WITH, 143),
+ (EXTENDED_ARG, 144),
+ (LIST_APPEND, 145),
+ (SET_ADD, 146),
+ (MAP_ADD, 147)
+ -- (EXCEPT_HANDLER, 257)
+ ]
+
+
+data BytecodeArg
+ = Arg16 Word16
+ -- Arg32 Word32 etcetera
+ deriving Show
+
+instance Pretty BytecodeArg where
+ pretty (Arg16 w) = pretty w
+
+data Bytecode =
+ Bytecode
+ { opcode :: Opcode
+ , args :: Maybe BytecodeArg
+ }
+ deriving Show
+
+instance Pretty Bytecode where
+ pretty (Bytecode { opcode = o, args = a }) = (text $ show o) <+> pretty a
+
+-- Number of bytes in a bytecode, counting the opcode plus any arguments
+bytecodeSize :: Bytecode -> Int
+bytecodeSize (Bytecode { args = a }) =
+ case a of
+ Nothing -> 1
+ Just (Arg16 _) -> 3
+
+newtype BytecodeSeq = BytecodeSeq [Bytecode]
+
+-- Print a sequence of bytecode with byte offsets
+instance Pretty BytecodeSeq where
+ pretty (BytecodeSeq bcs) =
+ vcat $ map prettyBcOffset bcsOffsets
+ where
+ offsets = scanl (\x y -> x + bytecodeSize y) 0 bcs
+ bcsOffsets = zip offsets bcs
+ prettyBcOffset :: (Int, Bytecode) -> Doc
+ prettyBcOffset (i, bc) = int i <+> pretty bc
+
+-- XXX is there a nicer way to define this?
+hasArg :: Opcode -> Bool
+hasArg = (>= STORE_NAME)
+
+-- XXX probably should have Error type
+decode :: ByteString -> [Bytecode]
+decode = decodeWords . B.unpack
+
+-- XXX probably should have error type
+encode :: [Bytecode] -> ByteString
+encode = B.pack . concatMap encodeBytecode
+
+encodeBytecode :: Bytecode -> [Word8]
+encodeBytecode (Bytecode opcode arg)
+ = case Map.lookup opcode opcodeToWord8 of
+ Nothing -> error ("bad opcode: " ++ show opcode)
+ Just w1 ->
+ case arg of
+ Nothing -> [w1]
+ Just (Arg16 arg16) ->
+ let (w2, w3) = word16ToWord8s arg16
+ in [w1, w2, w3]
+
+decodeWords :: [Word8] -> [Bytecode]
+decodeWords [] = []
+decodeWords (w:ws) =
+ case Map.lookup w word8ToOpcode of
+ Nothing -> error ("bad opcode: " ++ show (w:ws))
+ Just opcode ->
+ if hasArg opcode
+ then
+ case ws of
+ w1:w2:rest ->
+ let arg16 = Arg16 $ word8sToWord16 w1 w2 in
+ Bytecode opcode (Just arg16) : decodeWords rest
+ _other ->
+ error ("truncated bytecode stream: " ++ show (w:ws))
+ else
+ Bytecode opcode Nothing : decodeWords ws
+
+word8sToWord16 :: Word8 -> Word8 -> Word16
+word8sToWord16 w1 w2 = (fromIntegral w1) + (fromIntegral w2 `shiftL` 8)
+
+word16ToWord8s :: Word16 -> (Word8, Word8)
+word16ToWord8s w1 = (w2, w3)
+ where
+ w2 = fromIntegral (w1 .&. 255)
+ w3 = fromIntegral (w1 `shiftR` 8)
diff --git a/src/Blip/Marshal.hs b/src/Blip/Marshal.hs
new file mode 100644
index 0000000..9ad1a39
--- /dev/null
+++ b/src/Blip/Marshal.hs
@@ -0,0 +1,391 @@
+{-# LANGUAGE RecordWildCards #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Blip.Marshal
+-- Copyright : (c) 2012, 2013 Bernie Pope
+-- License : BSD-style
+-- Maintainer : florbitous@gmail.com
+-- Stability : experimental
+-- Portability : ghc
+--
+-- Reading, writing and representation of Python bytecode files.
+--
+-----------------------------------------------------------------------------
+
+module Blip.Marshal (readPyc, writePyc, PycFile (..), PyObject (..)) where
+
+import Blip.MarshalDouble (bytesToDouble, doubleToBytes)
+import Blip.Bytecode (decode, BytecodeSeq (..))
+import Blip.Pretty (Pretty (..), prettyList, prettyTuple)
+import Control.Applicative ((<$>), (<*>))
+import Data.Map as Map hiding (map, size)
+import Data.Word (Word8, Word32)
+import Control.Monad.Error (ErrorT (..), lift, replicateM)
+import System.IO (Handle)
+import qualified Data.ByteString.Lazy as B
+ (ByteString, hGetContents, unpack, hPutStr, length)
+import Data.ByteString.Lazy.UTF8 as UTF8 (toString, fromString)
+import Data.Binary.Get (Get, runGet, getLazyByteString, getWord32le, getWord8)
+import Data.Binary.Put (PutM, putWord32le, putLazyByteString, runPutM, putWord8)
+import Data.Int (Int64)
+import Data.Char (chr, ord)
+import Text.PrettyPrint
+ (text, (<+>), ($$), (<>), Doc , vcat, int, equals, doubleQuotes)
+
+data PycFile =
+ PycFile
+ { magic :: Word32
+ , modified_time :: Word32
+ , size :: Word32 -- the size in bytes of the original Python source
+ , object :: PyObject -- a code object
+ }
+ deriving Show
+
+instance Pretty PycFile where
+ pretty pycFile =
+ text "magic =" <+> pretty (magic pycFile) $$
+ text "modified time =" <+> pretty (modified_time pycFile) $$
+ text "size =" <+> pretty (size pycFile) $$
+ text "object =" <+> pretty (object pycFile)
+
+data PyObject
+ = Code
+ { argcount :: Word32 -- #arguments, except *args
+ , kwonlyargcount :: Word32 -- #keyword only arguments
+ , nlocals :: Word32 -- #local variables
+ , stacksize :: Word32 -- #entries needed for evaluation stack
+ , flags :: Word32 -- CO_..., see below
+ , code :: PyObject -- instruction opcodes (a string)
+ , consts :: PyObject -- list (constants used) XXX seems to be a tuple
+ , names :: PyObject -- list of strings (names used)
+ , varnames :: PyObject -- tuple of strings (local variable names)
+ , freevars :: PyObject -- tuple of strings (free variable names)
+ , cellvars :: PyObject -- tuple of strings (cell variable names)
+ , filename :: PyObject -- unicode (where it was loaded from)
+ , name :: PyObject -- unicode (name, for reference)
+ , firstlineno :: Word32 -- first source line number
+ , lnotab :: PyObject -- string (encoding addr<->lineno mapping)
+ }
+ | String { string :: B.ByteString }
+ | Tuple { elements :: [PyObject] }
+ | Int { int_value :: Word32 }
+ | Float { float_value :: Double }
+ | None
+ | Ellipsis
+ | Unicode { unicode :: String } -- should be decoded into a String
+ | TrueObj
+ | FalseObj
+ | Complex { real :: Double, imaginary :: Double }
+ deriving (Eq, Ord, Show)
+
+instance Pretty PyObject where
+ pretty (String {..}) = doubleQuotes $ pretty string
+ pretty (Tuple {..}) = prettyTuple $ map pretty elements
+ pretty (Int {..}) = pretty int_value
+ pretty (Float {..}) = pretty float_value
+ pretty None = text "None"
+ pretty Ellipsis = text "..."
+ pretty TrueObj = text "True"
+ pretty FalseObj = text "False"
+ pretty (Unicode {..}) = doubleQuotes $ text unicode
+ pretty (Code {..}) =
+ text "argcount =" <+> pretty argcount $$
+ text "kwonlyargcount =" <+> pretty kwonlyargcount $$
+ text "nlocals =" <+> pretty nlocals $$
+ text "stacksize =" <+> pretty stacksize $$
+ text "flags =" <+> pretty flags $$
+ text "varnames =" <+> pretty varnames $$
+ text "freevars =" <+> pretty freevars $$
+ text "cellvars =" <+> pretty cellvars $$
+ text "filename =" <+> pretty filename $$
+ text "name =" <+> pretty name $$
+ text "firstlineno =" <+> pretty firstlineno $$
+ text "lnotab =" <+> prettyLnotab lnotab $$
+ text "names =" <+> pretty names $$
+ prettyConsts consts $$
+ text "code =" <+> pretty (BytecodeSeq $ decode $ string code)
+ pretty (Complex {..}) = pretty real <+> text "+" <+> pretty imaginary <> text "j"
+
+prettyConsts :: PyObject -> Doc
+prettyConsts obj =
+ case obj of
+ Tuple {..} ->
+ vcat $ map prettyConst $ zip [0..] elements
+ _other -> text ("consts not a tuple: " ++ show obj)
+ where
+ prettyConst :: (Int, PyObject) -> Doc
+ prettyConst (i, obj) = text "const" <+> int i <+> equals <+> pretty obj
+
+prettyLnotab :: PyObject -> Doc
+prettyLnotab obj =
+ case obj of
+ String {..} -> prettyList $ map pretty $ B.unpack string
+ _other -> text ("lnotab not a string: " ++ show obj)
+
+readPyc :: Handle -> IO PycFile
+readPyc handle = do
+ bytes <- B.hGetContents handle
+ runGetDataCheck getPycFile bytes
+
+writePyc :: Handle -> PycFile -> IO ()
+writePyc handle pycFile = do
+ bytes <- runPutDataCheck $ putPycFile pycFile
+ B.hPutStr handle bytes
+
+getPycFile :: GetData PycFile
+getPycFile = PycFile <$> getU32 <*> getU32 <*> getU32 <*> readObject
+
+putPycFile :: PycFile -> PutData
+putPycFile pycFile = do
+ putU32 $ magic pycFile
+ putU32 $ modified_time pycFile
+ putU32 $ size pycFile
+ writeObject $ object pycFile
+
+readObject :: GetData PyObject
+readObject = do
+ object_type <- decodeObjectType <$> getU8
+ case object_type of
+ CODE -> readCodeObject
+ STRING -> readStringObject
+ TUPLE -> readTupleObject
+ INT -> readIntObject
+ NONE -> return None
+ ELLIPSIS -> return Ellipsis
+ TRUE -> return TrueObj
+ FALSE -> return FalseObj
+ UNICODE -> readUnicodeObject
+ BINARY_FLOAT -> readFloatObject
+ BINARY_COMPLEX -> readComplexObject
+ _other -> error ("readObject: unsupported object type: " ++ show object_type)
+
+writeObject :: PyObject -> PutData
+writeObject object =
+ case object of
+ Code {..} -> writeCodeObject object
+ String {..} -> writeStringObject object
+ Tuple {..} -> writeTupleObject object
+ Int {..} -> writeIntObject object
+ None -> putU8 $ encodeObjectType NONE
+ Ellipsis -> putU8 $ encodeObjectType ELLIPSIS
+ Unicode {..} -> writeUnicodeObject object
+ TrueObj -> putU8 $ encodeObjectType TRUE
+ FalseObj -> putU8 $ encodeObjectType FALSE
+ Float {..} -> writeFloatObject object
+ Complex {..} -> writeComplexObject object
+
+writeObjectType :: ObjectType -> PutData
+writeObjectType = putU8 . encodeObjectType
+
+readCodeObject :: GetData PyObject
+readCodeObject =
+ Code <$> getU32 <*> getU32 <*> getU32 <*> getU32 <*> getU32 <*>
+ readObject <*> readObject <*> readObject <*> readObject <*>
+ readObject <*> readObject <*> readObject <*> readObject <*>
+ getU32 <*> readObject
+
+writeCodeObject :: PyObject -> PutData
+writeCodeObject (Code {..}) =
+ writeObjectType CODE >>
+ mapM_ putU32 [argcount, kwonlyargcount, nlocals, stacksize, flags] >>
+ mapM_ writeObject [code, consts, names, varnames, freevars, cellvars,
+ filename, name] >>
+ putU32 firstlineno >>
+ writeObject lnotab
+writeCodeObject other = error $ "writeCodeObject called on non code object: " ++ show other
+
+readStringObject :: GetData PyObject
+readStringObject = do
+ len <- getU32
+ String <$> (getBS $ fromIntegral len)
+
+writeStringObject :: PyObject -> PutData
+writeStringObject (String {..}) =
+ writeObjectType STRING >>
+ putU32 (fromIntegral $ B.length string) >>
+ putBS string
+writeStringObject other = error $ "writStringObject called on non string object: " ++ show other
+
+readTupleObject :: GetData PyObject
+readTupleObject = do
+ len <- getU32
+ Tuple <$> replicateM (fromIntegral len) readObject
+
+writeTupleObject :: PyObject -> PutData
+writeTupleObject (Tuple {..}) =
+ writeObjectType TUPLE >>
+ putU32 (fromIntegral $ length elements) >>
+ mapM_ writeObject elements
+writeTupleObject other = error $ "writeTupleObject called on non tuple object: " ++ show other
+
+readIntObject :: GetData PyObject
+readIntObject = Int <$> getU32
+
+writeIntObject :: PyObject -> PutData
+writeIntObject (Int {..}) =
+ writeObjectType INT >> putU32 int_value
+writeIntObject other = error $ "writeIntObject called on non int object: " ++ show other
+
+readFloatObject :: GetData PyObject
+readFloatObject = Float <$> getDouble
+
+readComplexObject :: GetData PyObject
+readComplexObject = Complex <$> getDouble <*> getDouble
+
+writeFloatObject :: PyObject -> PutData
+writeFloatObject (Float {..}) =
+ writeObjectType BINARY_FLOAT >> putDouble float_value
+writeFloatObject other = error $ "writeFloatObject called on non float object: " ++ show other
+
+writeComplexObject :: PyObject -> PutData
+writeComplexObject (Complex {..}) =
+ writeObjectType BINARY_COMPLEX >> putDouble real >> putDouble imaginary
+writeComplexObject other = error $ "writeComplexObject called on non complex object: " ++ show other
+
+readUnicodeObject :: GetData PyObject
+readUnicodeObject = do
+ len <- getU32
+ bs <- getBS $ fromIntegral len
+ return $ Unicode $ UTF8.toString bs
+
+writeUnicodeObject :: PyObject -> PutData
+writeUnicodeObject (Unicode {..}) = do
+ writeObjectType UNICODE
+ let uc = UTF8.fromString unicode
+ putU32 (fromIntegral $ B.length uc)
+ putBS uc
+writeUnicodeObject other = error $ "writeUnicodeObject called on non unicode object: " ++ show other
+
+data ObjectType
+ = NULL -- '0'
+ | NONE -- 'N'
+ | FALSE -- 'F'
+ | TRUE -- 'T'
+ | STOPITER -- 'S'
+ | ELLIPSIS -- '.'
+ | INT -- 'i'
+
+ | INT64 -- 'I' INT64 is deprecated. It is not,
+ -- generated anymore, and support for reading it
+ -- will be removed in Python 3.4.
+
+ | FLOAT -- 'f'
+ | BINARY_FLOAT -- 'g'
+ | COMPLEX -- 'x'
+ | BINARY_COMPLEX -- 'y'
+ | LONG -- 'l'
+ | STRING -- 's'
+ | TUPLE -- '('
+ | LIST -- '['
+ | DICT -- '{'
+ | CODE -- 'c'
+ | UNICODE -- 'u'
+ | UNKNOWN -- '?'
+ | SET -- '<'
+ | FROZENSET -- '>'
+ deriving (Eq, Ord, Show)
+
+charToObjectType :: Map.Map Char ObjectType
+charToObjectType = Map.fromList objectTypeList
+
+objectTypeToChar :: Map.Map ObjectType Char
+objectTypeToChar = Map.fromList [ (y, x) | (x, y) <- objectTypeList ]
+
+objectTypeList :: [(Char, ObjectType)]
+objectTypeList = [
+ ('0', NULL),
+ ('N', NONE),
+ ('F', FALSE),
+ ('T', TRUE),
+ ('S', STOPITER),
+ ('.', ELLIPSIS),
+ ('i', INT),
+ ('I', INT64),
+ ('f', FLOAT),
+ ('g', BINARY_FLOAT),
+ ('x', COMPLEX),
+ ('y', BINARY_COMPLEX),
+ ('l', LONG),
+ ('s', STRING),
+ ('(', TUPLE),
+ ('[', LIST),
+ ('{', DICT),
+ ('c', CODE),
+ ('u', UNICODE),
+ ('?', UNKNOWN),
+ ('<', SET),
+ ('>', FROZENSET) ]
+
+encodeObjectType :: ObjectType -> Word8
+encodeObjectType objectType =
+ case Map.lookup objectType objectTypeToChar of
+ Nothing -> error $ "bad object type: " ++ show objectType
+ Just chr -> fromIntegral $ ord chr
+
+decodeObjectType :: Word8 -> ObjectType
+decodeObjectType byte =
+ case Map.lookup byteChar charToObjectType of
+ Nothing -> error $ "bad object type: " ++ show byteChar
+ Just t -> t
+ where
+ byteChar = chr $ fromIntegral byte
+
+-- utilities for reading binary data from a sequence of bytes
+type GetData a = ErrorT String Get a
+
+getDouble :: GetData Double
+getDouble = do
+ bs <- replicateM 8 getU8
+ return $ bytesToDouble bs
+
+getBS :: Int64 -> GetData B.ByteString
+getBS = lift . getLazyByteString
+
+-- read an unsigned 8 bit word
+getU8 :: GetData Word8
+getU8 = lift getWord8
+
+-- XXX is it always little endian?
+-- read an unsigned 32 bit word
+getU32 :: GetData Word32
+getU32 = lift getWord32le
+
+runGetData :: GetData a -> B.ByteString -> Either String a
+runGetData = runGet . runErrorT
+
+runGetDataCheck :: GetData a -> B.ByteString -> IO a
+runGetDataCheck g b =
+ case runGetData g b of
+ Left e -> fail e
+ Right v -> return v
+
+-- utilities for writing binary data to a sequence of bytes
+type PutData = ErrorT String PutM ()
+
+putDouble :: Double -> PutData
+putDouble d = mapM_ putU8 $ doubleToBytes d
+
+-- write a bytestring
+putBS :: B.ByteString -> PutData
+putBS = lift . putLazyByteString
+
+-- write an unsigned 8 bit word
+putU8 :: Word8 -> PutData
+putU8 = lift . putWord8
+
+-- XXX is it always little endian?
+-- write an unsigned 32 bit word
+putU32 :: Word32 -> PutData
+putU32 = lift . putWord32le
+
+runPutData :: PutData -> Either String B.ByteString
+runPutData comp =
+ case runPutM (runErrorT comp) of
+ (Left err, _) -> Left err
+ (Right (), bs) -> Right bs
+
+runPutDataCheck :: PutData -> IO B.ByteString
+runPutDataCheck comp =
+ case runPutData comp of
+ Left e -> fail e
+ Right bs -> return bs
diff --git a/src/Blip/MarshalDouble.hs b/src/Blip/MarshalDouble.hs
new file mode 100644
index 0000000..9d41da7
--- /dev/null
+++ b/src/Blip/MarshalDouble.hs
@@ -0,0 +1,42 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Blip.MarshalDouble
+-- Copyright : (c) 2012, 2013 Bernie Pope
+-- License : BSD-style
+-- Maintainer : florbitous@gmail.com
+-- Stability : experimental
+-- Portability : ghc
+--
+-- Convert Haskell Doubles to and from a list of bytes.
+--
+-- XXX not sure if this is complete or immune from endian issues.
+--
+-----------------------------------------------------------------------------
+
+module Blip.MarshalDouble (doubleToBytes, bytesToDouble) where
+
+import Foreign.Storable (peek, peekByteOff, pokeByteOff)
+import Foreign.Marshal.Utils (with)
+import Foreign.Marshal.Alloc (alloca)
+import Data.Word (Word8)
+import Control.Monad (forM, forM_)
+import System.IO.Unsafe (unsafePerformIO)
+
+doubleToBytes :: Double -> [Word8]
+doubleToBytes = unsafePerformIO . doubleToBytesIO
+
+doubleToBytesIO :: Double -> IO [Word8]
+doubleToBytesIO d =
+ with d $ \ptr ->
+ forM [0..7] $ \index ->
+ peekByteOff ptr index
+
+bytesToDouble :: [Word8] -> Double
+bytesToDouble = unsafePerformIO . bytesToDoubleIO
+
+bytesToDoubleIO :: [Word8] -> IO Double
+bytesToDoubleIO bs =
+ alloca $ \ptr -> do
+ forM_ (zip [0..7] bs) $ \(index, byte) ->
+ pokeByteOff ptr index byte
+ peek ptr
diff --git a/src/Blip/Pretty.hs b/src/Blip/Pretty.hs
new file mode 100644
index 0000000..46a6b71
--- /dev/null
+++ b/src/Blip/Pretty.hs
@@ -0,0 +1,84 @@
+-----------------------------------------------------------------------------
+-- |
+-- Copyright : (c) 2012
+-- License : BSD-style
+-- Maintainer : florbitous@gmail.com
+-- Stability : experimental
+-- Portability : ghc
+--
+-- Pretty printing utilities.
+--
+-----------------------------------------------------------------------------
+
+module Blip.Pretty
+ ( Pretty (..)
+ , prettyString
+ , prettyList
+ , prettyTuple
+ , showBits
+ )where
+
+import Data.Word (Word64, Word32, Word16, Word8)
+import Text.PrettyPrint
+import Data.ByteString.Lazy (ByteString)
+import Data.ByteString.Lazy.Char8 (unpack)
+import Data.Bits (testBit, Bits, bitSize)
+
+-- -----------------------------------------------------------------------------
+
+-- | Pretty printing interface.
+class Pretty a where
+ -- ^ Generate a document for a value.
+ pretty :: a -> Doc
+
+prettyList :: [Doc] -> Doc
+prettyList = brackets . hcat . punctuate comma
+
+prettyTuple :: [Doc] -> Doc
+prettyTuple = parens . hcat . punctuate comma
+
+-- | Render an instance of "Pretty" as a "String".
+prettyString :: Pretty a => a -> String
+prettyString = render . pretty
+
+instance Pretty a => Pretty (Maybe a) where
+ pretty Nothing = empty
+ pretty (Just x) = pretty x
+
+instance Pretty Word8 where
+ pretty = integer . fromIntegral
+
+instance Pretty Word16 where
+ pretty = integer . fromIntegral
+
+instance Pretty Word32 where
+ pretty = integer . fromIntegral
+
+instance Pretty Word64 where
+ pretty = integer . fromIntegral
+
+instance Pretty Int where
+ pretty = int
+
+instance Pretty Integer where
+ pretty = integer
+
+instance Pretty Double where
+ pretty = double
+
+instance (Pretty a, Pretty b) => Pretty (a, b) where
+ pretty (x, y) = text "(" <> pretty x <> text "," <+> pretty y <> text ")"
+
+instance Pretty ByteString where
+ pretty = text . unpack
+
+-- | Render an instance of "Bits" as a list of "Bool", where "True" represents the high bit and "False" represents the low bit.
+bits :: Bits a => a -> [Bool]
+bits x = map (testBit x) [0 .. bitSize x - 1]
+
+-- | Render an instance of "Bits" as a "String".
+showBits :: Bits a => a -> String
+showBits = map toBit . bits
+ where
+ toBit True = '1'
+ toBit False = '0'
diff --git a/src/Blip/Version.hs b/src/Blip/Version.hs
new file mode 100644
index 0000000..a0a39e6
--- /dev/null
+++ b/src/Blip/Version.hs
@@ -0,0 +1,19 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Blip.Version
+-- Copyright : (c) 2012, 2013 Bernie Pope
+-- License : BSD-style
+-- Maintainer : florbitous@gmail.com
+-- Stability : experimental
+-- Portability : ghc
+--
+-- Version number of Blip, derived magically from cabal file.
+--
+-----------------------------------------------------------------------------
+module Blip.Version (version, versionString) where
+
+import Paths_bliplib (version)
+import Data.Version (showVersion)
+
+versionString :: String
+versionString = showVersion version