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.4 +version: 0.6 stability: experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -18,7 +18,7 @@ . exam.hs: . - > import Binary + > import File.Binary > import System.Environment > import Data.ByteString as BS > @@ -57,7 +57,7 @@ > 4: verticalResolution > 4: numberOfColors > 4: importantColors - > 4[numberOfColors]: colors + > 4<(Int, Int, Int)>[numberOfColors]: colors > -- bitsPerPixel/8[imageSize*8/bitsPerPixel]: image > imageSize: image > 10: authorFirst @@ -68,7 +68,7 @@ library hs-source-dirs: src - exposed-modules: Binary + exposed-modules: File.Binary other-modules: QuoteBinaryStructure, ParseBinaryStructure, Here build-depends: base > 3 && < 5, template-haskell, peggy, bytestring ghc-options: -Wall diff --git a/src/Binary.hs b/src/Binary.hs deleted file mode 100644 --- a/src/Binary.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Binary ( - readBinaryFile, - writeBinaryFile, - binary - ) where - -import QuoteBinaryStructure -import System.IO - -readBinaryFile :: FilePath -> IO String -readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents - -writeBinaryFile :: FilePath -> String -> IO () -writeBinaryFile path str = do - h <- openBinaryFile path WriteMode - hPutStr h str - hClose h diff --git a/src/File/Binary.hs b/src/File/Binary.hs new file mode 100644 --- /dev/null +++ b/src/File/Binary.hs @@ -0,0 +1,17 @@ +module File.Binary ( + readBinaryFile, + writeBinaryFile, + binary + ) where + +import QuoteBinaryStructure +import System.IO + +readBinaryFile :: FilePath -> IO String +readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents + +writeBinaryFile :: FilePath -> String -> IO () +writeBinaryFile path str = do + h <- openBinaryFile path WriteMode + hPutStr h str + hClose h diff --git a/src/ParseBinaryStructure.hs b/src/ParseBinaryStructure.hs --- a/src/ParseBinaryStructure.hs +++ b/src/ParseBinaryStructure.hs @@ -43,8 +43,9 @@ 4: colorIndexNumber 4: neededIndexNumber -4[colorIndexNumber]: colors +4<(Int,Int,Int)>[colorIndexNumber]: colors -- 1[3]: image +imageSize: image 10: author 10: hoge @@ -65,7 +66,7 @@ constantInt (ConstantInt v) = v constantInt (ConstantString v) = readInt v -data Type = String | Int | ByteString deriving Show +data Type = String | Int | ByteString | Tuple [Type] deriving (Show, Eq) data VariableValue = VariableValue { variableValue :: String } @@ -139,12 +140,23 @@ = [A-Z][a-zA-Z0-9]* { $1 : $2 } dat :: BinaryStructureItem - = expr type size? ':' spaces val emptyLines + = expr typ size? ':' spaces val emptyLines { binaryStructureItem $1 $2 $3 $5 } -type :: Type - = "" { String } - / "" { ByteString } - / ""? { Int } +typ :: Type + = [<] typeGen [>] { $2 } + / "" { Int } + +typeGen :: Type + = [(] tupleGen [)] { Tuple $2 } + / "String" { String } + / "ByteString" { ByteString } + / "Int" { Int } + +tupleGen :: [Type] + = typeGen spaces "," spaces tupleGen + { $1 : $4 } + / typeGen spaces "," spaces typeGen + { [$1, $4] } expr :: Expression = expr '*' expr { Multiple $1 $2 } diff --git a/src/QuoteBinaryStructure.hs b/src/QuoteBinaryStructure.hs --- a/src/QuoteBinaryStructure.hs +++ b/src/QuoteBinaryStructure.hs @@ -59,13 +59,75 @@ Either Int String -> ExpQ writeField bs size Int Nothing (Left n) = appsE [varE 'fi, expression bs size, litE $ integerL $ fromIntegral n] -writeField bs size Int Nothing (Right v) = - appsE [varE 'fi, expression bs size, getField bs v] -writeField bs size Int (Just n) (Right v) = appE (varE 'cc) $ appsE [varE 'map, - appE (varE 'fi) (expression bs size), getField bs v] -writeField bs size String Nothing (Right v) = appE (varE 'fs) $ getField bs v -writeField bs size ByteString Nothing (Right v) = appE (varE 'fbs) $ getField bs v +writeField bs bytes typ size (Right v) = + fieldValueToStr 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 + 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] + 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] +-} + +addZeros :: Int -> ExpQ +addZeros ln = do + lst <- newName "lst" + let bdy = infixApp (varE lst) (varE '(++)) $ + appsE [varE 'replicate, litE $ integerL $ fromIntegral ln, varE 'zero] + lam1E (varP lst) bdy + +correctSize' :: ExpQ -> ExpQ +correctSize' size = do +-- let size = litE $ IntegerL 100 + lst <- newName "lst" + let bdy = infixApp (varE lst) (varE '(++)) $ + appsE [varE 'replicate, + infixApp size (varE '(-)) $ appE (varE 'length) $ varE lst, + varE 'zero] + lam1E (varP lst) bdy + +correctSize :: ExpQ -> ExpQ -> ExpQ +correctSize size list = infixApp list (varE '(++)) $ + appsE [varE 'replicate, + infixApp size (varE '(-)) $ appE (varE 'length) list, + varE 'zero] + +newNameList :: Int -> Q [Name] +newNameList 0 = return [] +newNameList n = liftA2 (:) (newName "x") $ newNameList (n - 1) + +mapTuple :: (Type -> ExpQ) -> [Type] -> ExpQ +mapTuple f ts = varE 'show + intToBin :: Int -> Int -> String intToBin n x = intToBinGen (fromIntegral n) (fromIntegral x) @@ -125,6 +187,18 @@ (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 cs'' <- newName "cs" def <- valD (varP $ fromJust $ lookup var np) @@ -139,6 +213,18 @@ where n = expression ret $ bytesOf item +strToTupple :: Int -> ExpQ +strToTupple n = (toTupple n) `dot` appE (varE 'map) (varE 'ord) `dot` + appE (varE 'take) (litE $ integerL $ fromIntegral n) + +dot :: ExpQ -> ExpQ -> ExpQ +dot f1 f2 = infixApp f1 (varE '(.)) f2 + +toTupple :: Int -> ExpQ +toTupple n = do + nl <- newNameList n + lam1E (listP $ map varP nl) (tupE $ map varE nl) + expression :: Name -> Expression -> ExpQ expression ret (Variable v) = appE (varE $ mkName v) (varE ret) expression _ (Number n) = litE $ integerL $ fromIntegral n @@ -191,24 +277,27 @@ vsts = flip map (filter isRight body) $ \item -> case (sizeOf item, typeOf item) of - (Nothing, Int) -> varStrictType - (mkName $ fromRight $ valueOf item) $ - strictType notStrict $ conT ''Int - (_, Int) -> varStrictType - (mkName $ fromRight $ valueOf item) $ - strictType notStrict $ - appT listT $ conT ''Int - (Nothing, String) -> varStrictType - (mkName $ fromRight $ valueOf item) $ - strictType notStrict $ conT ''String - (Nothing, ByteString) -> varStrictType + (sz, tp) -> varStrictType (mkName $ fromRight $ valueOf item) $ - strictType notStrict $ conT ''BS.ByteString - + strictType notStrict $ mkType (isJust sz) tp -- conT ''Int isRight item | Right _ <- valueOf 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 + +appsT :: [TypeQ] -> TypeQ +appsT [t] = t +appsT (t1 : t2 : ts) = appsT (appT t1 t2 : ts) + +mkTupleReader :: [Type] -> ExpQ +mkTupleReader _ = varE 'show + fromRight = either (error "not Right") id devideN :: Int -> [a] -> [[a]] @@ -225,6 +314,7 @@ ti :: a -> Int fi :: Int -> Int -> a cc :: [a] -> a + zero :: a instance Str String where tk = take @@ -236,6 +326,7 @@ ti = readInt fi = intToBin cc = concat + zero = "\0" instance Str BS.ByteString where tk = BS.take @@ -247,3 +338,4 @@ ti = readInt . map (chr . fromIntegral) . BS.unpack fi n = BS.pack . map (fromIntegral . ord) . intToBin n cc = BS.concat + zero = BS.singleton 0