diff --git a/LICENSE b/LICENSE new file mode 100644 --- /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 --- /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 --- /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 +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 --- /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 --- /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 --- /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 --- /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 --- /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