diff --git a/binary-file.cabal b/binary-file.cabal --- a/binary-file.cabal +++ b/binary-file.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: binary-file -version: 0.6 +version: 0.12.6 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -19,24 +19,33 @@ exam.hs: . > import File.Binary + > import File.Binary.Data.LittleEndian > import System.Environment > import Data.ByteString as BS > > main = do > [inf, outf] <- getArgs > - > -- cnt <- readBinaryFile inf > cnt <- BS.readFile inf - > let bmp = readBitmap cnt - > print $ readBitmap cnt + > let bmp = readBitmap $ cnt `BS.append` replicate 20 ' ' + > print bmp > > let out = writeBitmap bmp { > authorFirst = "Yoshikuni ", > authorSecond = "Jujo " > } - > -- writeBinaryFile outf out > BS.writeFile outf out > + > instance RetType (Int, Int, Int) where + > type Argument (Int, Int, Int) = () + > fromType _ (b, g, r) = cc $ [ + > fromType 1 b, fromType 1 g, fromType 1 r, zero] + > toType _ str = let + > (b, rest) = toType 1 str + > (g, rest') = toType 1 rest + > (r, rest'') = toType 1 rest' in + > ((b, g, r), dp 1 rest'') + > > [binary| > > Bitmap @@ -46,6 +55,7 @@ > 2: 0 > 2: 0 > 4: offset + > > 4: 40 > 4: bitmapWidth > 4: bitmapHeight @@ -57,18 +67,24 @@ > 4: verticalResolution > 4: numberOfColors > 4: importantColors - > 4<(Int, Int, Int)>[numberOfColors]: colors - > -- bitsPerPixel/8[imageSize*8/bitsPerPixel]: image - > imageSize: image + > ((), Just numberOfColors)<[(Int, Int, Int)]>: colors + > imageSize: image + > > 10: authorFirst > 10: authorSecond > > |] . +source-repository head + type: git + location: git://github.com/YoshikuniJujo/binary-file.git + library hs-source-dirs: src - exposed-modules: File.Binary - other-modules: QuoteBinaryStructure, ParseBinaryStructure, Here + exposed-modules: File.Binary, + File.Binary.Data.LittleEndian, + File.Binary.Data.BigEndian + other-modules: QuoteBinaryStructure, ParseBinaryStructure, Here, Classes build-depends: base > 3 && < 5, template-haskell, peggy, bytestring ghc-options: -Wall diff --git a/src/Classes.hs b/src/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Classes.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE + TemplateHaskell, + TypeSynonymInstances, + FlexibleInstances, + TypeFamilies, + OverloadedStrings #-} + +module Classes ( + RetType(..), + Str(..), + retTypeInt, + fii, fiiBE, + tii, tiiBE, + Endian(..) +) where + +import qualified Data.ByteString as BS +import ParseBinaryStructure +import Data.Char +import Language.Haskell.TH + +class RetType r where + type Argument r + fromType :: Str s => Argument r -> r -> s + toType :: Str s => Argument r -> s -> (r, s) + +instance RetType r => RetType [r] where + type Argument [r] = (Argument r, Maybe Int) + fromType (a, _) rs = cc $ map (fromType a) rs + toType (a, Just b) s = (b `times` toType a) s + toType (a, Nothing) s = whole (toType a) s + +retTypeInt :: Endian -> DecsQ +retTypeInt endian = fmap (:[]) $ + instanceD (cxt []) (appT (conT ''RetType) (conT ''Int)) [argt, dfii, dtii] + where + argt = tySynInstD ''Argument [conT ''Int] $ conT ''Int + dfii = valD (varP 'fromType) (normalB $ fiiend) [] + dtii = valD (varP 'toType) (normalB $ tiiend) [] + sffx = case endian of + LittleEndian -> "" + BigEndian -> "BE" + fiiend = varE $ mkName $ "fii" ++ sffx + tiiend = varE $ mkName $ "tii" ++ sffx + +{- +instance RetType Int where + fromType = fii + toType = tii +-} + +{- +instance RetType String where + type Argument String = Int + fromType _ = fs + toType _ str = (ts str, undefined) +-} + +instance RetType Char where + type Argument Char = () + fromType _ = fs . (: []) + toType _ str = (head $ ts str, dp 1 str) + +instance RetType BS.ByteString where + type Argument BS.ByteString = Int + fromType _ = fbs + toType n str = (tbs $ tk n str, dp n str) +-- toType n str = (tbs $ tk n str, fs $ show (len str) ++ show n ++ "hoge hoge hage hage ") -- dp n str) + +class Str a where + tk :: Int -> a -> a + dp :: Int -> a -> a + ts :: a -> String + fs :: String -> a + fbs :: BS.ByteString -> a + tbs :: a -> BS.ByteString + ti :: a -> Integer + fi :: Int -> Integer -> a + tiBE :: a -> Integer + fiBE :: Int -> Integer -> a + cc :: [a] -> a + zero :: a + len :: a -> Int + empty :: a -> Bool + rev :: a -> a + +instance Str String where + tk = take + dp = drop + ts = id + fs = id + fbs = ts + tbs = fs + ti = readInt LittleEndian + fi = intToBin LittleEndian + tiBE = readInt BigEndian + fiBE = intToBin BigEndian + cc = concat + zero = "\0" + len = length + empty = null + rev = reverse + +fii, fiiBE :: Str a => Int -> Int -> a +fii n = fi n . fromIntegral +fiiBE n = fiBE n . fromIntegral +tii, tiiBE :: Str a => Int -> a -> (Int, a) +tii _ str = (fromIntegral $ ti $ tk 4 str, dp 4 str) +tiiBE _ str = (fromIntegral $ tiBE $ tk 4 str, dp 4 str) + +instance Str BS.ByteString where + tk = BS.take + dp = BS.drop + ts = map (chr . fromIntegral) . BS.unpack + fs = BS.pack . map (fromIntegral . ord) + fbs = id + tbs = id + ti = readInt LittleEndian . map (chr . fromIntegral) . BS.unpack + fi n = BS.pack . map (fromIntegral . ord) . intToBin LittleEndian n + tiBE = readInt BigEndian . map (chr . fromIntegral) . BS.unpack + fiBE n = BS.pack . map (fromIntegral . ord) . intToBin BigEndian n + cc = BS.concat + zero = BS.singleton 0 + len = BS.length + empty = (== 0) . BS.length + rev = BS.reverse + +intToBin :: Endian -> Int -> Integer -> String +intToBin LittleEndian 0 _ = "" +intToBin LittleEndian n x = chr (fromIntegral $ x `mod` 256) : + intToBin LittleEndian (fromIntegral n - 1) (x `div` 256) +intToBin BigEndian n x = reverse $ intToBin LittleEndian n x + +times :: Int -> (s -> (ret, s)) -> s -> ([ret], s) +times 0 _ s = ([], s) +times n f s = let + (ret, rest) = f s + (rets, rest') = times (n - 1) f rest in + (ret : rets, rest') + +whole :: Str s => (s -> (ret, s)) -> s -> ([ret], s) +whole f s + | empty s = ([], s) + | otherwise = let + (ret, rest) = f s + (rets, rest') = whole f rest in + (ret : rets, rest') diff --git a/src/File/Binary.hs b/src/File/Binary.hs --- a/src/File/Binary.hs +++ b/src/File/Binary.hs @@ -1,7 +1,12 @@ module File.Binary ( readBinaryFile, writeBinaryFile, - binary + binary, + RetType(..), + Str(..), + tii, tiiBE, + fii, fiiBE +-- times ) where import QuoteBinaryStructure diff --git a/src/File/Binary/Data/BigEndian.hs b/src/File/Binary/Data/BigEndian.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/Data/BigEndian.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module File.Binary.Data.BigEndian where + +import Classes + +-- retTypeInt BigEndian + +instance RetType Int where + type Argument Int = Int + fromType n = rev . fi n . fromIntegral + toType n s = (fromIntegral $ ti $ rev $ tk n s, dp n s) diff --git a/src/File/Binary/Data/LittleEndian.hs b/src/File/Binary/Data/LittleEndian.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary/Data/LittleEndian.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module File.Binary.Data.LittleEndian where + +import Classes + +-- retTypeInt LittleEndian + +instance RetType Int where + type Argument Int = Int + fromType n = fi n . fromIntegral + toType n s = (fromIntegral $ ti $ tk n s, dp n s) diff --git a/src/ParseBinaryStructure.hs b/src/ParseBinaryStructure.hs --- a/src/ParseBinaryStructure.hs +++ b/src/ParseBinaryStructure.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} module ParseBinaryStructure ( + Endian(..), BinaryStructure(..), BinaryStructureItem, Expression(..), @@ -10,13 +11,17 @@ sizeOf, valueOf, parseBinaryStructure, - readInt + readInt, + isRepeat, + getRepeat ) where import Text.Peggy import Here import Control.Arrow import Data.Char +import Language.Haskell.TH hiding (Type) +import Numeric hiding (readInt) main :: IO () main = do @@ -25,6 +30,8 @@ BitmapFileHeader +set big_endian + 2: 19778 4: fileSize 2: 0 @@ -43,73 +50,105 @@ 4: colorIndexNumber 4: neededIndexNumber +(4, colorIndexNumber)<[Int]>: colors 4<(Int,Int,Int)>[colorIndexNumber]: colors -- 1[3]: image imageSize: image 10: author 10: hoge +10: some +10: "abc\n\r\SUB" +10: 0x89 +repeat { + +Chank + +4: chankSize +4: chankData +chankSize: chankData +4:chankCRC + +} + |] data Expression = Multiple Expression Expression | Division Expression Expression + | Addition Expression Expression | Variable String | Number Int - deriving Show + | ExpressionQ {expressionQ :: Name -> ExpQ} +instance Show Expression where + show _ = "Expression" + +sumExp :: [Expression] -> Expression +sumExp [] = Number 0 +sumExp (e1 : e2) = Addition e1 $ sumExp e2 + data ConstantValue = ConstantInt Int | ConstantString String deriving Show -constantInt (ConstantInt v) = v -constantInt (ConstantString v) = readInt v +constantInt endian (ConstantInt v) = v +constantInt endian (ConstantString v) = fromIntegral $ readInt endian v -data Type = String | Int | ByteString | Tuple [Type] deriving (Show, Eq) +data Type +-- = Tuple [Type] + = Type { typeQ :: TypeQ } -- String +instance Show Type where + show _ = "Type" + data VariableValue = VariableValue { variableValue :: String } deriving Show -data BinaryStructureItem = BinaryStructureItem { - binaryStructureItemBytes :: Expression, - binaryStructureItemType :: Type, - binaryStructureItemListSize :: Maybe Expression, -- (Either Int String), - binaryStructureItemValue :: Either ConstantValue VariableValue -- Int String - } deriving Show +data BinaryStructureItem + = BinaryStructureItem { + binaryStructureItemBytes :: Expression, + binaryStructureItemType :: Type, + binaryStructureItemListSize :: Maybe Expression, -- (Either Int String), + binaryStructureItemValue :: Either ConstantValue VariableValue -- Int String + } + | Repeat { getRepeat :: BinaryStructure } + deriving Show +isRepeat (Repeat _) = True +isRepeat _ = False + bytesOf :: BinaryStructureItem -> Expression -bytesOf = binaryStructureItemBytes +bytesOf (Repeat BinaryStructure{binaryStructureBody = body}) = + sumExp $ map bytesOf body +bytesOf BinaryStructureItem { binaryStructureItemBytes = b } = b typeOf :: BinaryStructureItem -> Type -typeOf = binaryStructureItemType +typeOf (Repeat BinaryStructure{binaryStructureName = name}) = + Type $ appT listT $ conT $ mkName name +typeOf BinaryStructureItem{binaryStructureItemType = t} = t sizeOf :: BinaryStructureItem -> Maybe Expression -sizeOf = binaryStructureItemListSize +sizeOf (Repeat BinaryStructure{}) = Nothing +sizeOf BinaryStructureItem{binaryStructureItemListSize = s} = s -valueOf :: BinaryStructureItem -> Either Int String -valueOf = (constantInt +++ variableValue) . binaryStructureItemValue +valueOf :: Endian -> BinaryStructureItem -> Either Int String +valueOf endian BinaryStructureItem { binaryStructureItemValue = v } = + (constantInt endian +++ variableValue) v +valueOf endian (Repeat BinaryStructure{binaryStructureName = name}) = + Right $ "repeat" ++ name binaryStructureItem :: Expression -> Type -> Maybe Expression -> Either ConstantValue VariableValue -> BinaryStructureItem binaryStructureItem = BinaryStructureItem -{- -type BinaryStructureItem = (Int, Either Int String) - -bytesOf :: (Int, Either Int String) -> Int -bytesOf = fst - -valueOf :: (Int, Either Int String) -> Either Int String -valueOf = snd - -binaryStructureItem :: Int -> Either Int String -> BinaryStructureItem -binaryStructureItem = (,) --} +data Endian = BigEndian | LittleEndian deriving Show data BinaryStructure = BinaryStructure { binaryStructureName :: String, + binaryStructureEndian :: Endian, binaryStructureBody :: [BinaryStructureItem] } deriving Show @@ -118,16 +157,26 @@ Right bs -> bs Left ps -> error $ show ps -readInt :: String -> Int -readInt "" = 0 -readInt (c : cs) = ord c + 2 ^ 8 * readInt cs +readInt :: Endian -> String -> Integer +readInt LittleEndian "" = 0 +readInt LittleEndian (c : cs) = fromIntegral (ord c) + 2 ^ 8 * readInt LittleEndian cs +readInt BigEndian str = readInt LittleEndian $ reverse str +tupT :: [TypeQ] -> TypeQ +tupT ts = foldl appT (tupleT $ length ts) ts + [peggy| top :: BinaryStructure - = emptyLines name emptyLines dat* - { BinaryStructure $2 $4 } + = emptyLines name emptyLines endian emptyLines dat* + { BinaryStructure $2 $4 $6 } + / emptyLines name emptyLines dat* + { BinaryStructure $2 LittleEndian $4 } +endian :: Endian + = "set" spaces "big_endian" + { BigEndian } + emptyLines :: () = "--" [^\n]* [\n] { () } / [ \n]* { () } @@ -142,43 +191,84 @@ dat :: BinaryStructureItem = expr typ size? ':' spaces val emptyLines { binaryStructureItem $1 $2 $3 $5 } + / "repeat" spaces "{" top "}" + { Repeat $2 } typ :: Type = [<] typeGen [>] { $2 } - / "" { Int } + / "" { Type $ conT $ mkName "Int" } typeGen :: Type - = [(] tupleGen [)] { Tuple $2 } - / "String" { String } - / "ByteString" { ByteString } - / "Int" { Int } + = [(] tupleGen_ [)] { Type $ tupT $2 } + / [\[] typeGen [\]] { Type $ appT listT $ typeQ $2 } +-- = [(] tupleGen [)] { Tuple $2 } + / [A-Z][.a-zA-Z0-9]* { Type $ conT $ mkName $ $1 : $2 } +typeGen_ :: TypeQ + = [A-Z][.a-zA-Z0-9]* { conT $ mkName $ $1 : $2 } + +tupleGen_ :: [TypeQ] + = typeGen_ spaces "," spaces tupleGen_ + { $1 : $4 } + / typeGen_ spaces "," spaces typeGen_ + { [$1, $4] } + tupleGen :: [Type] = typeGen spaces "," spaces tupleGen { $1 : $4 } / typeGen spaces "," spaces typeGen { [$1, $4] } +-- = [\(] [\)] { ExpressionQ $ const $ conE $ mkName "()" } expr :: Expression = expr '*' expr { Multiple $1 $2 } / expr '/' expr { Division $1 $2 } - / num { Number $1 } - / var { Variable $1 } + / expr '+' expr { Addition $1 $2 } + / num { ExpressionQ $ const $ litE $ integerL $ fromIntegral $1 } + / var { ExpressionQ $ appE (varE $ mkName $1) . varE } + / [(] tupleExpr [)] { ExpressionQ $2 } + / 'Just' spaces expr { ExpressionQ $ \ret -> appE (conE $ mkName "Just") $ + expressionQ $2 ret } + / 'Nothing' { ExpressionQ $ const $ conE $ mkName "Nothing" } +-- / [(] expr ', ' expr [)] +-- { ExpressionQ $ \ret -> tupE +-- [expressionQ $2 ret, expressionQ $3 ret] } + +tupleExpr :: Name -> ExpQ + = expr ', ' expr { \ret -> tupE + [expressionQ $1 ret, expressionQ $2 ret] } + / "" { const $ conE $ mkName "()" } + size :: Expression = '[' expr ']' val :: Either ConstantValue VariableValue = num { Left $ ConstantInt $1 } / var { Right $ VariableValue $1 } - / stringL { Left $ ConstantString $1 } + / stringLit { Left $ ConstantString $1 } -stringL :: String - = '\"' [^\"]* '\"' +stringLit :: String + = '\"' strL '\"' +strL :: String + = charLit* + +charLit :: Char + = [^\\\"] + / "\\" escLit + +escLit :: Char + = "n" { '\n' } + / "r" { '\r' } + / "\\" { '\\' } + / "SUB" { '\SUB' } + var :: String - = [a-z][a-zA-Z0-9]* { $1 : $2 } + = [a-z][_a-zA-Z0-9]* { $1 : $2 } num :: Int - = [0-9]+ { read $1 } + = '0x' [0-9a-fA-F]+ { fst $ head $ readHex $1 } + / [1-9][0-9]* { read $ $1 : $2 } + / '0' { 0 } |] diff --git a/src/QuoteBinaryStructure.hs b/src/QuoteBinaryStructure.hs --- a/src/QuoteBinaryStructure.hs +++ b/src/QuoteBinaryStructure.hs @@ -6,7 +6,12 @@ FlexibleInstances #-} module QuoteBinaryStructure ( - binary + binary, + RetType(..), + Str(..), + fii, fiiBE, + tii, tiiBE, + times ) where import Prelude hiding (sequence) @@ -22,6 +27,7 @@ import Data.Bits import ParseBinaryStructure +import Classes import qualified Data.ByteString as BS @@ -39,64 +45,52 @@ mkHaskellTree :: BinaryStructure -> DecsQ mkHaskellTree BinaryStructure{ binaryStructureName = bsn, + binaryStructureEndian = endian, binaryStructureBody = body } = do - d <- mkData bsn body --- dbg <- debugReadType - r <- mkReader bsn body - w <- mkWriter bsn body - return [d, r, w] + d <- mkData endian bsn body + r <- mkReader endian bsn body + w <- mkWriter endian bsn body + i <- retTypeInt endian + return $ d ++ [r, w] -mkWriter :: String -> [BinaryStructureItem] -> DecQ -mkWriter bsn body = do +mkWriter :: Endian -> String -> [BinaryStructureItem] -> DecQ +mkWriter endian bsn body = do bs <- newName "bs" let run = appE (varE 'cc) $ listE $ map - (\bsi -> writeField bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi) (valueOf bsi)) + (\bsi -> writeField endian bs (bytesOf bsi) (typeOf bsi) (sizeOf bsi) + (valueOf endian bsi)) body funD (mkName $ "write" ++ bsn) [clause [varP bs] (normalB run) []] -writeField :: Name -> Expression -> Type -> Maybe Expression -> +writeField :: Endian -> Name -> Expression -> Type -> Maybe Expression -> Either Int String -> ExpQ -writeField bs size Int Nothing (Left n) = - appsE [varE 'fi, expression bs size, litE $ integerL $ fromIntegral n] -writeField bs bytes typ size (Right v) = - fieldValueToStr bs bytes (isJust size) typ $ getField bs v +writeField endian bs size (Type _) Nothing (Left n) = + appsE [fiend, expression bs size, litE $ integerL $ fromIntegral n] + where + fiend = case endian of + LittleEndian -> varE 'fii + BigEndian -> varE 'fiiBE +writeField endian bs bytes typ size (Right v) = + fieldValueToStr endian bs bytes (isJust size) typ $ getField bs v -fieldValueToStr :: Name -> Expression -> Bool -> Type -> ExpQ -> ExpQ -fieldValueToStr bs size False Int = appE $ appE (varE 'fi) (expression bs size) -fieldValueToStr bs size True Int = appE (varE 'cc) . appE (appsE [varE 'map, - appE (varE 'fi) (expression bs size)]) -fieldValueToStr bs size False String = appE $ varE 'fs -fieldValueToStr bs size False ByteString = appE $ varE 'fbs -fieldValueToStr bs size False (Tuple ts) = \val -> do - nl <- newNameList $ length ts - let def = valD (tupP $ map varP nl) (normalB val) [] - bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl - in letE [def] $ appE (varE 'cc) $ listE bdy -fieldValueToStr bs size True (Tuple ts) = \val -> do +fiend :: Endian -> ExpQ +fiend endian = case endian of + LittleEndian -> varE 'fii + BigEndian -> varE 'fiiBE + +fieldValueToStr :: Endian -> Name -> Expression -> Bool -> Type -> ExpQ -> ExpQ +fieldValueToStr endian bs size False (Type typ) = + appE $ appE (varE 'fromType) (expression bs size) +fieldValueToStr endian bs size True typ = \val -> do runIO $ do - putStrLn "here" - print ts - nl <- newNameList $ length ts - let ps = tupP $ map varP nl - bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl - in appE (varE 'cc) $ appsE [ - varE 'map, - lamE [ps] $ appE (varE 'cc) $ addZero $ listE bdy, - val] + putStrLn "there" + appE (varE 'cc) $ appsE [ + varE 'map, appE (varE 'fromType) (expression bs size), val] where - addZero = -- appE $ addZeros 1 - appE $ correctSize' $ expression bs size -{- - let ps = tupP $ map varP nl - bdy = zipWith (fieldValueToStr bs (Number 1) False) ts $ map varE nl - in appE (varE 'cc) $ appE (correctSize' $ expression bs size) $ appsE [ - varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val] --} -{- - in appE (varE 'cc) $ correctSize (expression bs size) $ appsE [ - varE 'map, lamE [ps] $ appE (varE 'cc) $ listE bdy, val] --} + addZero = appE $ correctSize' $ expression bs size + +fieldValueToStr endian bs size bool typ = error $ show (endian, bs, size, bool, typ) addZeros :: Int -> ExpQ addZeros ln = do @@ -107,7 +101,6 @@ correctSize' :: ExpQ -> ExpQ correctSize' size = do --- let size = litE $ IntegerL 100 lst <- newName "lst" let bdy = infixApp (varE lst) (varE '(++)) $ appsE [varE 'replicate, @@ -128,90 +121,62 @@ mapTuple :: (Type -> ExpQ) -> [Type] -> ExpQ mapTuple f ts = varE 'show -intToBin :: Int -> Int -> String -intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x) - -intToBinGen :: Integer -> Integer -> String -intToBinGen 0 _ = "" -intToBinGen n x = chr (fromIntegral $ x `mod` 256) : - intToBinGen (n - 1) (x `div` 256) - --- readerType :: String -> DecQ --- readerType = sigD (mkName $ "read" ++ bsn) [t| Str a => a -> - --- debugReadType :: DecQ = [d| readBitmap :: Str a => a -> Bitmap |] - -mkReader :: String -> [BinaryStructureItem] -> DecQ -mkReader bsn body = do +mkReader :: Endian -> String -> [BinaryStructureItem] -> DecQ +mkReader endian bsn body = do cs <- newName "cs" ret <- newName "ret" funD (mkName $ "read" ++ bsn) - [clause [varP cs] (normalB $ mkLetRec ret $ mkBody bsn body cs) []] + [clause [varP cs] (normalB $ mkLetRec ret $ + mkBody endian bsn body cs) []] mkLetRec :: Name -> (Name -> ExpQ) -> ExpQ -mkLetRec n f = letE [valD (varP n) (normalB $ f n) []] $ varE n +mkLetRec n f = do + rest <- newName "rest" + letE [valD (tupP [varP n, varP rest]) (normalB $ f n) []] $ + tupE [varE n, varE rest] -mkBody :: String -> [BinaryStructureItem] -> Name -> Name -> ExpQ -mkBody bsn body cs ret = do +mkBody :: Endian -> String -> [BinaryStructureItem] -> Name -> Name -> ExpQ +mkBody endian bsn body cs ret = do namePairs <- for names $ \n -> return . (n ,) =<< newName "tmp" - defs <- gather cs body $ mkDef namePairs - letE (map return defs) $ recConE (mkName bsn) (map toPair2 namePairs) + (defs, rest) <- gather cs body $ mkDef namePairs + letE (map return defs) $ tupE + [recConE (mkName bsn) (map toPair2 namePairs), varE rest] where - names = rights $ map valueOf body + names = rights $ map (valueOf endian) body toPair2 (n, nn) = return $ (mkName n, VarE nn) mkValD v = valD (varP v) (normalB $ litE $ integerL 45) [] mkDef :: [(String, Name)] -> BinaryStructureItem -> Name -> Q ([Dec], Name) mkDef np item cs' - | Left val <- valueOf item = do + | Left val <- valueOf endian item = do cs'' <- newName "cs" let t = dropE' n $ varE cs' - let p = val `equal` appE (varE 'ti) (takeE' n $ varE cs') + let p = val `equal` appE (varE 'fst) + (appE tiend $ takeE' n $ varE cs') let e = [e| error "bad value" |] d <- valD (varP cs'') (normalB $ condE p t e) [] return ([d], cs'') - | Right var <- valueOf item, Nothing <- sizeOf item, Int <- typeOf item = do - cs'' <- newName "cs" - def <- valD (varP $ fromJust $ lookup var np) - (normalB $ appE (varE 'ti) $ takeE' n $ varE cs') [] - next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') [] - return ([def, next], cs'') - | Right var <- valueOf item, Nothing <- sizeOf item, ByteString <- typeOf item = do - cs'' <- newName "cs" - def <- valD (varP $ fromJust $ lookup var np) - (normalB $ takeE'' n $ varE cs') [] - next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') [] - return ([def, next], cs'') - | Right var <- valueOf item, Nothing <- sizeOf item = do + | Right var <- valueOf endian item, Just expr <- sizeOf item = do cs'' <- newName "cs" - def <- valD (varP $ fromJust $ lookup var np) - (normalB $ takeE' n $ varE cs') [] - next <- valD (varP cs'') (normalB $ dropE' n $ varE cs') [] - return ([def, next], cs'') - | Right var <- valueOf item, Just expr <- sizeOf item, Tuple ts <- typeOf item = - if all (== Int) ts then do - cs'' <- newName "cs" - def <- valD (varP $ fromJust $ lookup var np) - (normalB $ - appsE [varE 'map, strToTupple $ length ts, - appsE [varE 'devideN, n, - takeE' (multiE' n $ expression ret expr) $ varE cs']]) [] - next <- valD (varP cs'') (normalB $ - dropE' (multiE' n $ expression ret expr) $ varE cs') [] - return ([def, next], cs'') - else error "hogeru" - | Right var <- valueOf item, Just expr <- sizeOf item = do + def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs'']) + (normalB (appsE + [(varE 'times), expression ret expr, + appE (varE 'toType) arg, varE cs'])) + [] + return ([def], cs'') + | Right var <- valueOf endian item, Nothing <- sizeOf item, + Type typ <- typeOf item = do cs'' <- newName "cs" - def <- valD (varP $ fromJust $ lookup var np) - (normalB $ - appsE [varE 'map, varE 'ti, - appsE [varE 'devideN, n, - takeE' (multiE' n $ expression ret expr) $ varE cs']]) [] - next <- valD (varP cs'') (normalB $ - dropE' (multiE' n $ expression ret expr) $ varE cs') [] - return ([def, next], cs'') + def <- valD (tupP [varP $ fromJust $ lookup var np, varP cs'']) + (normalB $ appE (appE (varE 'toType) arg) $ varE cs') [] + return ([def], cs'') | otherwise = error $ show $ typeOf item where n = expression ret $ bytesOf item + tiend' = varE 'toType + tiend = case endian of + LittleEndian -> appE (varE 'tii) (litE $ integerL 4) + BigEndian -> appE (varE 'tiiBE) (litE $ integerL 4) + arg = expression ret $ bytesOf item strToTupple :: Int -> ExpQ strToTupple n = (toTupple n) `dot` appE (varE 'map) (varE 'ord) `dot` @@ -230,6 +195,8 @@ expression _ (Number n) = litE $ integerL $ fromIntegral n expression ret (Division x y) = divE (expression ret x) (expression ret y) expression ret (Multiple x y) = multiE' (expression ret x) (expression ret y) +expression ret (Addition x y) = addE' (expression ret x) (expression ret y) +expression ret (ExpressionQ e) = e ret getField :: Name -> String -> ExpQ getField bs v = appE (varE $ mkName v) (varE bs) @@ -240,37 +207,52 @@ multiE' :: ExpQ -> ExpQ -> ExpQ multiE' x y = infixE (Just x) (varE '(*)) (Just y) +addE' :: ExpQ -> ExpQ -> ExpQ +addE' x y = infixE (Just x) (varE '(+)) (Just y) + divE :: ExpQ -> ExpQ -> ExpQ divE x y = infixE (Just x) (varE 'div) (Just y) equal :: Int -> ExpQ -> ExpQ equal x y = infixE (Just $ litE $ integerL $ fromIntegral x) (varE '(==)) (Just y) --- takeE :: Int -> ExpQ -> ExpQ --- takeE n xs = appsE [varE 'tk, litE $ integerL $ fromIntegral n, xs] - takeE' :: ExpQ -> ExpQ -> ExpQ takeE' n xs = appE (varE 'ts) $ appsE [varE 'tk, n, xs] takeE'' :: ExpQ -> ExpQ -> ExpQ takeE'' n xs = appE (varE 'tbs) $ appsE [varE 'tk, n, xs] --- dropE :: Int -> ExpQ -> ExpQ --- dropE n xs = appsE [varE 'dp, litE $ integerL $ fromIntegral n, xs] - dropE' :: ExpQ -> ExpQ -> ExpQ dropE' n xs = appsE [varE 'dp, n, xs] -gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m [b] -gather s [] f = return [] +gather :: Monad m => s -> [a] -> (a -> s -> m ([b], s)) -> m ([b], s) +gather s [] f = return ([], s) gather s (x : xs) f = do (ys, s') <- f x s - zs <- gather s' xs f - return $ ys ++ zs + (zs, s'') <- gather s' xs f + return $ (ys ++ zs, s'') -mkData :: String -> [BinaryStructureItem] -> DecQ -mkData bsn body = - dataD (cxt []) name [] [con] [''Show] +makeData :: BinaryStructure -> DecsQ +makeData BinaryStructure{ + binaryStructureName = bsn, + binaryStructureEndian = endian, + binaryStructureBody = body } = mkData endian bsn body + +mkInstance :: String -> DecQ +mkInstance name = + instanceD (cxt []) (appT (conT ''RetType) (conT $ mkName name)) [ + valD (varP $ 'fromType) + (normalB $ varE $ mkName $ "write" ++ name) [], + valD (varP $ 'toType) + (normalB $ varE $ mkName $ "read" ++ name) [] + ] + +mkData :: Endian -> String -> [BinaryStructureItem] -> DecsQ +mkData endian bsn body = do + d <- dataD (cxt []) name [] [con] [''Show] + mkInstance bsn + ds <- mapM makeData $ map getRepeat $ filter isRepeat body + return $ [d] ++ concat ds where name = mkName bsn con = recC (mkName bsn) vsts @@ -278,18 +260,16 @@ vsts = flip map (filter isRight body) $ \item -> case (sizeOf item, typeOf item) of (sz, tp) -> varStrictType - (mkName $ fromRight $ valueOf item) $ - strictType notStrict $ mkType (isJust sz) tp -- conT ''Int + (mkName $ fromRight $ valueOf endian item) $ + strictType notStrict $ + mkType (isJust sz) tp isRight item - | Right _ <- valueOf item = True + | Right _ <- valueOf endian item = True | otherwise = False mkType :: Bool -> Type -> TypeQ mkType True t = appT listT $ mkType False t -mkType False Int = conT ''Int -mkType False String = conT ''String -mkType False ByteString = conT ''BS.ByteString -mkType False (Tuple ts) = appsT $ tupleT (length ts) : map (mkType False) ts +mkType False (Type typ) = typ appsT :: [TypeQ] -> TypeQ appsT [t] = t @@ -304,38 +284,9 @@ devideN _ [] = [] devideN n xs = take n xs : devideN n (drop n xs) -class Str a where - tk :: Int -> a -> a - dp :: Int -> a -> a - ts :: a -> String - fs :: String -> a - fbs :: BS.ByteString -> a - tbs :: a -> BS.ByteString - ti :: a -> Int - fi :: Int -> Int -> a - cc :: [a] -> a - zero :: a - -instance Str String where - tk = take - dp = drop - ts = id - fs = id - fbs = ts - tbs = fs - ti = readInt - fi = intToBin - cc = concat - zero = "\0" - -instance Str BS.ByteString where - tk = BS.take - dp = BS.drop - ts = map (chr . fromIntegral) . BS.unpack - fs = BS.pack . map (fromIntegral . ord) - fbs = id - tbs = id - ti = readInt . map (chr . fromIntegral) . BS.unpack - fi n = BS.pack . map (fromIntegral . ord) . intToBin n - cc = BS.concat - zero = BS.singleton 0 +times :: Int -> (s -> (ret, s)) -> s -> ([ret], s) +times 0 _ s = ([], s) +times n f s = let + (ret, rest) = f s + (rets, rest') = times (n - 1) f rest in + (ret : rets, rest')