bliplib (empty) → 0.1.0
raw patch · 8 files changed
+948/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, mtl, pretty, utf8-string
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- bliplib.cabal +38/−0
- src/Blip/Bytecode.hs +341/−0
- src/Blip/Marshal.hs +391/−0
- src/Blip/MarshalDouble.hs +42/−0
- src/Blip/Pretty.hs +84/−0
- src/Blip/Version.hs +19/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ bliplib.cabal view
@@ -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+}
+ src/Blip/Bytecode.hs view
@@ -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)
+ src/Blip/Marshal.hs view
@@ -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
+ src/Blip/MarshalDouble.hs view
@@ -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
+ src/Blip/Pretty.hs view
@@ -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'
+ src/Blip/Version.hs view
@@ -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