diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2012, Michael Baikov + +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 Michael Baikov 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/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,174 @@ +parsergen +========= + +[![Build Status](https://secure.travis-ci.org/tsurucapital/parsergen.png?branch=master)](http://travis-ci.org/tsurucapital/parsergen) + +Introduction +------------ + +`parsergen` is a library aimed at generating fast Haskell parsers for fixed +width packets. It uses a DSL in which these packets can be specified, augmented +with Haskell parsers. + +In order to create a packet and a parser for it, usually two files are used, +`Foo.hs` and `Foo.ths`. + +Tutorial +-------- + +### Datatypes and parsers + +#### Syntax + +Let's start by defining a datatype in the `.ths` file. The syntax here is: + + TypeName + ConstructorName [fields prefix] + [Nx] [_]FieldName [!] FieldType [+]FieldWidth [FieldParser] + +where + +- `TypeName`: Name of the type itself, e.g. `Maybe` + +- `ConstructorName`: Name of constructor with given set of fields. If no prefix + is provided, downcased capital letters from the constructor name will be used + instead. + +- `Nx`: Number of times to repeat this matcher + +- `FieldName`: Name of the field which will be used (with constructor prefix + prepended) + +- `_`: This field will be ignored (skipped if possible or parsed) + +- `!`: This field will be strict + +- `FieldType`: type name when using existing datatype, e.g. `Int` or + `ByteString`, or a custom type `Foo` + +- `FieldWidth`: Number for size based parsing, e.g. `12`. This field is needed + to perform some optimisations as well, so you have to specify field width even + if you going to specify `FieldParser`. + +- `+`: Only for numerical fields: the first character will be treated as the + sign + +- `FieldParser`: A parser which will be used to parse it. This can be omitted + for types such as `Int` or `ByteString`. Otherwise, you can either specify a + fixed string or a parser of the type `Parser`. + +In the `.hs` file, one can now use: + + $(genDataTypeFromFile "Foo.ths") + $(genParserFromFile "Foo.ths") + +to generate a parser and a datatype for it. + +#### Example + +Let's look at an example `.ths` file: + + Packet + Warning + _PacketType ByteString 4 "WARN" + DangerType DangerType 2 dangerType + ChanceOfSurvival Int 3 + + LotteryWin + _PacketType ByteString 4 "LOTT" + Amount Money 10 + 6x WinningEntry LotteryEntry 2 + +And the `.hs` file: + + {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} + import Data.ByteString (ByteString) + import ParserGen.Gen + import ParserGen.Repack -- Needed later on + import qualified ParserGen.Parser as P + + data DangerType + = Earthquake + | ZombieApocalypse + | RobotUprising + | AngryGirlfriend + deriving (Eq, Show) + + dangerType :: P.Parser DangerType + dangerType = do + bs <- P.take 2 + case bs of + "EQ" -> return Earthquake + "ZA" -> return ZombieApocalypse + "RI" -> return RobotUprising + "AG" -> return AngryGirlfriend + _ -> fail $ "Unknown danger type: " ++ show bs + + newtype Money = Money Int + deriving (Eq, Show) + + type LotteryEntry = Int + + $(genDataTypeFromFile "Packet.ths") + $(genParserFromFile "Packet.ths") + + sampleWarning :: ByteString + sampleWarning = "WARNRI002" + + sampleLotteryWin :: ByteString + sampleLotteryWin = "LOTT9999999999040815162342" + + main :: IO () + main = do + print $ P.parse parserForWarning sampleWarning + print $ P.parse parserForLotteryWin sampleLotteryWin + +The `parsergen` generates: + +- The `Packet` datatype +- The parser functions `parserForWarning, parserForLotteryWin :: Parser Packet` + +Note how we have used three kinds of parsers: + +- `"WARN"` is an example of a hardcoded string which the packet must match +- `dangerType` is a custom parser, specified in the Haskell file +- We don't specify parsers for numeral types, these are automatically derived + (even for `newtype`s and `type` synonyms) + +### Repackers + +A powerful feature from the library, repackers allow us to change the contents +of multiple fields without actually parsing a packet. + +#### Syntax + +The syntax looks like this: + + repackerForName ConstructorName + FieldName [FieldUnParser] + +#### Example + +Let's add the following the bottom of our `.ths` file: + + repackerForLotteryNumbers LotteryWin + WinningEntry + +And the following to our Haskell file: + + $(genRepackFromFile "Packet.ths") + +which generates the function + + repackerForLotteryNumbers :: [LotteryEntry] -> ByteString -> ByteString + +Use it like: + + print $ repackerForLotteryNumbers [1 .. 6] sampleLotteryWin + +Things to note: + +- For numerical types, you don't need to specify an unparser, this is only + needed for custom types. These should have the type `SomeType -> ByteString`. +- The repacker will take a list when the field is repeated (e.g. `6x` in this + case) and a single value otherwise diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/parsergen.cabal b/parsergen.cabal new file mode 100644 --- /dev/null +++ b/parsergen.cabal @@ -0,0 +1,73 @@ +Name: parsergen +Version: 0.2.0.0 +Synopsis: TH parser generator for splitting bytestring into fixed-width fields + +Description: + For more information, see the README: + . + + +License: BSD3 +License-file: LICENSE +Author: Michael Baikov +Maintainer: manpacket@gmail.com +Category: Data +Build-type: Simple +Cabal-version: >= 1.8 + +Extra-source-files: + README.markdown + tests/ParserGen/Tests/Packet.ths + +Library + Ghc-options: -Wall + Hs-source-dirs: src + + Exposed-modules: + ParserGen + ParserGen.Common + ParserGen.Gen + ParserGen.Parser + ParserGen.Repack + + Other-modules: + ParserGen.Auto + ParserGen.ParseQuote + ParserGen.Types + + Build-depends: + base >= 3 && < 5, + bytestring >= 0.9 && < 0.10, + directory >= 1.1 && < 2, + filepath >= 1.2 && < 2, + parsec >= 3 && < 4, + template-haskell >= 2.5 && < 3 + +Test-suite parsergen-tests + Ghc-options: -Wall + Hs-source-dirs: src tests + Main-is: TestSuite.hs + Type: exitcode-stdio-1.0 + + Other-modules: + ParserGen.Common.Tests + ParserGen.Tests + ParserGen.Tests.Packet + + Build-depends: + HUnit >= 1.2 && < 1.3, + QuickCheck >= 2.4 && < 2.6, + test-framework >= 0.4 && < 0.7, + test-framework-hunit >= 0.2 && < 0.3, + test-framework-quickcheck2 >= 0.2 && < 0.3, + -- Copied from regular dependencies... + base >= 3 && < 5, + bytestring >= 0.9 && < 0.10, + directory >= 1.1 && < 2, + filepath >= 1.2 && < 2, + parsec >= 3 && < 4, + template-haskell >= 2.5 && < 3 + +Source-repository head + Type: git + Location: git://github.com/tsurucapital/parsergen.git diff --git a/src/ParserGen.hs b/src/ParserGen.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen.hs @@ -0,0 +1,11 @@ +module ParserGen + ( module ParserGen.Common + , module ParserGen.Gen + , module ParserGen.Parser + , module ParserGen.Repack + ) where + +import ParserGen.Common +import ParserGen.Gen +import ParserGen.Parser +import ParserGen.Repack diff --git a/src/ParserGen/Auto.hs b/src/ParserGen/Auto.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Auto.hs @@ -0,0 +1,115 @@ +-- | Utilities for automatically deriving parsers and unparsers for certain +-- types +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Auto + ( getFieldParserUnparser + ) where + +import Control.Applicative (pure, (<$>), (<*>)) +import Control.Monad (liftM2, mplus, replicateM) +import qualified Data.ByteString.Char8 as BC +import Language.Haskell.TH + +import ParserGen.Common +import ParserGen.Types +import qualified ParserGen.Parser as P + +getFieldParserUnparser :: DataField -> Maybe Exp -> Q (Exp, Maybe Exp) +getFieldParserUnparser df mCustomUnparser = do + (parser, unparser) <- mkFieldParser (fieldParser df) + (getTypeName $ fieldType df) (fieldWidth df) (getFieldIsIgnored df) + + parser' <- repeatParser df parser + unparser' <- maybe (return Nothing) (fmap Just . repeatUnparser df) $ + mplus mCustomUnparser unparser + return (parser', unparser') + +mkFieldParser :: ParserType -> Name -> Int -> Bool -> Q (Exp, Maybe Exp) +mkFieldParser pty ftyname fwidth fignored + | fignored = wn [|P.unsafeSkip fwidth|] + | otherwise = case pty of + CustomParser p -> return (p, Nothing) + UnsignedParser -> case nameBase ftyname of + "AlphaNum" -> wj [|unsafeAlphaNum fwidth|] [|putAlphaNum|] + "ByteString" -> wj [|P.unsafeTake fwidth|] [|id|] + "Int" -> wj (unsafeDecimalXTH fwidth) [|putDecimalX fwidth|] + x -> recurse x + SignedParser -> case nameBase ftyname of + "Int" -> wj (unsafeDecimalXSTH fwidth) [|putDecimalXS fwidth|] + x -> recurse x + + HardcodedString s + | length s /= fwidth -> fail $ + "Width of " ++ show s ++ " is not " ++ show fwidth ++ "!" + -- if string value is ignored - no need to return it + | fignored -> wn [|P.string (BC.pack s)|] + | otherwise -> + wn [|P.string (BC.pack s) >> return (BC.pack s)|] + where + recurse ty = do + (ftyname', cons, uncons) <- getTypeConsUncons ty + (fparser, funparser) <- mkFieldParser pty ftyname' fwidth fignored + liftM2 (,) [|$(return cons) `fmap` $(return fparser)|] $ + case funparser of + Nothing -> return Nothing + Just f -> fmap Just [|\x -> $(return f) ($(return uncons) x)|] + + -- | Utility + wj x y = (,) <$> x <*> fmap Just y + wn x = (,) <$> x <*> pure Nothing + +-- | The following function takes a type name and generates a proper name, +-- a constructor and an unconstror for it. +-- +-- Example: given the type +-- +-- > data Wrap = Wrap Int +-- +-- We will generate a constructor expression which is equivalent to +-- +-- > Wrap :: Int -> Wrap +-- +-- and an unconstructor expression equivalent to +-- +-- > \w -> let Wrap uw = w in uw :: Wrap -> Int +-- +getTypeConsUncons :: String -> Q (Name, Exp, Exp) +getTypeConsUncons name = do + TyConI info <- recover (fail unknownType) (reify (mkName name)) + id' <- [|id|] + case info of + TySynD _ _ (ConT synTo) -> + return (synTo, id', id') + + NewtypeD _ _ _ (RecC constr [(unconstr, _, ConT typeFor)]) _ -> + return (typeFor, ConE constr, VarE unconstr) + + NewtypeD _ _ _ (NormalC constr [(_, ConT typeFor)]) _ -> do + + -- I don't think there's a simpler way? + w <- newName "w" + uw <- newName "uw" + let unconstr = LamE [VarP w] (LetE + [ValD (ConP constr [VarP uw]) (NormalB (VarE w)) []] + (VarE uw)) + + return (typeFor, ConE constr, unconstr) + + _ -> fail $ + "Can't deal with " ++ name ++ ", must be a type synonym or newtype" + where + unknownType = "Type `" ++ name ++ "' is undefined." + +repeatParser :: DataField -> Exp -> Q Exp +repeatParser df p = case fieldRepeat df of + Nothing -> return p + Just q -> [|replicateM q $(return p)|] + +repeatUnparser :: DataField -> Exp -> Q Exp +repeatUnparser df up + | getFieldHasRepeat df = [|map $(return up)|] + | otherwise = [|return . $(return up)|] + +getTypeName :: Type -> Name +getTypeName (ConT n) = n +getTypeName t = error $ "Invalid type in size based parser: " ++ show t diff --git a/src/ParserGen/Common.hs b/src/ParserGen/Common.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Common.hs @@ -0,0 +1,144 @@ +-- | Parsing and unparsing for commonly used datatypes +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Common + ( unsafeDecimalX + , unsafeDecimalXTH + , putDecimalX + + , unsafeDecimalXS + , unsafeDecimalXSTH + , putDecimalXS + + , AlphaNum (..) + , unsafeAlphaNum + , putAlphaNum + ) where + +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.Unsafe as B +import Data.Char (chr, ord) +import Data.Int (Int64) +import Language.Haskell.TH + +import ParserGen.Parser (Parser) +import qualified ParserGen.Parser as P + +unsafeDecimalX :: Int -> Parser Int +unsafeDecimalX l = P.unsafeTake l >>= go + where + go bs = loop 0 0 + where + loop !acc !i + | i >= l = return acc + | otherwise = + let x = fromIntegral (B.unsafeIndex bs i) + in if x < ord '0' || x > ord '9' + then fail $ "not an Int: " ++ show bs + else loop (acc * 10 - ord '0' + x) (i + 1) + {-# INLINE go #-} +{-# INLINE unsafeDecimalX #-} + +-- | This is a template-haskell based version of 'unsafeDecimalX' which +-- generates a fast, unrolled loop +unsafeDecimalXTH :: Int -> Q Exp +unsafeDecimalXTH size = do + bs <- newName "bs" + go' <- go bs (LitE (IntegerL 0)) 0 + [|P.unsafeTake size >>= $(return $ LamE [VarP bs] go')|] + where + go :: Name -> Exp -> Int -> Q Exp + go bs prevacc i + | i >= size = [|return $(return prevacc)|] + | otherwise = do + x <- newName $ "x" ++ show i + acc <- newName $ "var" ++ show i + xv <- [|fromIntegral (B.unsafeIndex $(varE bs) i) :: Int|] + accv <- [|$(return prevacc) * 10 + $(varE x) - ord '0'|] + next <- go bs (VarE acc) (i + 1) + + body <- [| if $(varE x) < ord '0' || $(varE x) > ord '9' + then fail $ "Not an Int " ++ show $(varE bs) + else $(return next) |] + + return $ LetE + [ ValD (VarP x) (NormalB xv) [] + , ValD (BangP (VarP acc)) (NormalB accv) [] + ] body + +putDecimalX :: Int -> Int -> ByteString +putDecimalX l i = BC.pack $ putDecimalXString l i + +unsafeDecimalXS :: Int -> Parser Int +unsafeDecimalXS l = sign <*> unsafeDecimalX l +{-# INLINE unsafeDecimalXS #-} + +unsafeDecimalXSTH :: Int -> Q Exp +unsafeDecimalXSTH size = [|sign <*> $(unsafeDecimalXTH size)|] + +-- | Helper function +sign :: Parser (Int -> Int) +sign = do + raw <- BC.head <$> P.unsafeTake 1 + case raw of + '+' -> return id + ' ' -> return id + '0' -> return id + '-' -> return negate + inv -> fail $ "Invalid sign: " ++ show inv +{-# INLINE sign #-} + +putDecimalXS :: Int -> Int -> ByteString +putDecimalXS l i + | i >= 0 = BC.pack $ ' ' : putDecimalXString l i + | otherwise = BC.pack $ '-' : putDecimalXString l (negate i) + +-- | Helper function +putDecimalXString :: Int -> Int -> String +putDecimalXString l i + | i >= 0 = reverse . take l . reverse $ (replicate l '0' ++ show i) + | otherwise = + error "ParserGen.Repack: Can't put negative decimal X: " ++ show i + +-- | Can keep up to 12 characters from 0..9, A..Z +newtype AlphaNum = AlphaNum {unAlphaNum :: Int64} + deriving (Show, Eq, Enum) + +unsafeAlphaNum :: Int -> Parser AlphaNum +unsafeAlphaNum l = P.unsafeTake l >>= go + where + go bs = loop 0 0 + where + fail' = fail $ "Invalid alphanum: " ++ show bs + -- We assume some things about the ascii layout, and get better + -- branching that way... + loop !acc !i + | i >= l = + return $ AlphaNum acc + | w <= c2w '9' = if w < c2w '0' + then fail' + else loop (36 * acc + (fromIntegral $ w - c2w '0')) (i + 1) + | otherwise = if w < c2w 'A' || w > c2w 'Z' + then fail' + else loop (36 * acc + (fromIntegral $ w - c2w 'A' + 10)) (i + 1) + where + w = B.unsafeIndex bs i + {-# INLINE go #-} +{-# INLINE unsafeAlphaNum #-} + +putAlphaNum :: AlphaNum -> ByteString +putAlphaNum (AlphaNum an) = fst $ BC.unfoldrN 12 f (36 ^ (11 :: Int)) + where + f :: Int64 -> Maybe (Char, Int64) + f i | i <= 0 = Nothing + | l >= 10 = Just (chr $ l - 10 + ord 'A', i `div` 36) + | otherwise = Just (chr $ l + ord '0', i `div` 36) + where + -- Expensive? :-( + l = fromIntegral $ (an `div` i) `mod` 36 + {-# INLINE f #-} +{-# INLINE putAlphaNum #-} diff --git a/src/ParserGen/Gen.hs b/src/ParserGen/Gen.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Gen.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Gen + ( genDataTypeFromFile + , genParserFromFile + , genWidthFromFile + ) where + +import Language.Haskell.TH as TH +import Control.Applicative +import Control.Monad +import Data.Char (isUpper, toLower) +import Data.Maybe (catMaybes) + +import ParserGen.Auto +import ParserGen.ParseQuote +import qualified ParserGen.Parser as P +import ParserGen.Types + +genDataTypeFromFile :: FilePath -> Q [Dec] +genDataTypeFromFile templateName = getDatatypes templateName >>= mapM mkDataDecl + +genParserFromFile :: FilePath -> Q [Dec] +genParserFromFile = getDatatypes >=> fmap concat . mapM mkParsersDecls + +genWidthFromFile :: FilePath -> Q [Dec] +genWidthFromFile = getDatatypes >=> fmap concat . mapM mkWidthDecls + +mkDataDecl :: Datatype -> Q Dec +mkDataDecl (Datatype {..}) = do + constrs <- mapM mkConstDef typeConstrs + return $ DataD [] (mkName typeName) [] constrs [''Eq, ''Show] + where + mkConstDef :: DataConstructor -> Q Con + mkConstDef dc@(DataConstructor {..}) = do + fields <- catMaybes <$> mapM (mkFieldDef dc) constrFields + return $ RecC (mkName constrName) fields + +mkFieldDef :: DataConstructor -> DataField -> Q (Maybe (Name, Strict, Type)) +mkFieldDef dc@(DataConstructor {..}) df@(DataField {..}) = return $ do + name <- getFieldName dc df + return (name, strict, getFieldRepeatType df) + where + strict :: Strict + strict = if fieldStrict then IsStrict else NotStrict + +getFieldName :: DataConstructor -> DataField -> Maybe Name +getFieldName (DataConstructor {..}) (DataField {..}) = + mkName <$> ((++) <$> (constrPrefix <|> defaultPrefix) <*> fieldName) + where + defaultPrefix = Just (map toLower . filter isUpper $ constrName) + +-- to create separate parsers for each constructor +mkParsersDecls :: Datatype -> Q [Dec] +mkParsersDecls (Datatype {..}) = + concat <$> mapM (mkConstrParser typeName) typeConstrs + where + mkConstrParser :: String -> DataConstructor -> Q [Dec] + mkConstrParser name dc@(DataConstructor {..}) = do + fields <- mapM mkField (fuseIgnores constrFields) + ensure <- ensureBytes $ getConstructorWidth dc + t <- [t| P.Parser |] + return + [ SigD funName (AppT t (ConT . mkName $ name )) + , FunD funName + [Clause [] (NormalB . DoE $ ensure : fields ++ [result] ) []] + ] + where + ensureBytes :: Int -> Q Stmt + ensureBytes t = [| P.ensureBytesLeft t |] >>= return . NoBindS + + funName :: Name + funName = mkName $ "parserFor" ++ constrName + + prime :: Name -> Name + prime n = mkName $ nameBase n ++ "'" + + mkField :: DataField -> Q Stmt + mkField df@(DataField {..}) = do + (parser, _) <- getFieldParserUnparser df Nothing + return $ case getFieldName dc df of + Just n -> BindS (VarP $ prime n) parser + _ -> NoBindS parser + + result :: Stmt + result = NoBindS (AppE (VarE . mkName $ "return") + (RecConE (mkName constrName) + (concatMap mkFieldAssignment constrFields))) + + mkFieldAssignment :: DataField -> [FieldExp] + mkFieldAssignment df@(DataField {..}) = case getFieldName dc df of + Just n -> [(n, VarE $ prime n)] + Nothing -> [] + +-- | Transforms sequence of size-based parsers with ignored values into one +-- larger parser +fuseIgnores :: [DataField] -> [DataField] +fuseIgnores (a : b : rest) + | getFieldIsIgnored a && getFieldIsIgnored b = fuseIgnores $ fused : rest + | otherwise = a : fuseIgnores (b : rest) + where + fused = DataField { fieldName = Nothing + , fieldStrict = False + , fieldRepeat = Nothing + , fieldType = (ConT . mkName $ "()") + , fieldParser = UnsignedParser + , fieldWidth = getFieldWidth a + getFieldWidth b + } + +fuseIgnores (x : xs) = x : fuseIgnores xs +fuseIgnores [] = [] + +mkWidthDecls :: Datatype -> Q [Dec] +mkWidthDecls (Datatype {..}) = concat <$> mapM mkConstrWidthDecl typeConstrs + where + mkConstrWidthDecl :: DataConstructor -> Q [Dec] + mkConstrWidthDecl dc@(DataConstructor {..}) = return + [ SigD name (ConT $ mkName "Int") + , FunD name [Clause [] (NormalB $ LitE $ IntegerL width) []] + ] + where + width = fromIntegral $ getConstructorWidth dc + name = mkName $ "widthFor" ++ constrName diff --git a/src/ParserGen/ParseQuote.hs b/src/ParserGen/ParseQuote.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/ParseQuote.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE RecordWildCards, FlexibleContexts #-} +module ParserGen.ParseQuote + ( getDecls + , getDatatypes + , getRepackers + ) where + +import Control.Applicative hiding (many, (<|>), optional) +import Control.Monad (unless, (>=>)) +import Data.Char (chr) +import Data.List (isPrefixOf) +import Language.Haskell.TH as TH +import System.Directory (getCurrentDirectory) +import System.FilePath.Posix ((), takeDirectory) +import Text.Parsec hiding (spaces) +import Text.Parsec.Pos + +import ParserGen.Types + +type ParserQ = ParsecT String () Q + +getDecls :: FilePath -> Q [Decl] +getDecls = getTemplate >=> parseDecls + +getDatatypes :: FilePath -> Q [Datatype] +getDatatypes = fmap (fst . unzipDecls) . getDecls + +getRepackers :: FilePath -> Q [Repacker] +getRepackers = fmap (snd . unzipDecls) . getDecls + +getTemplate :: FilePath -> Q (SourcePos, String) +getTemplate templateName = do + filename <- loc_filename <$> location + pwd <- runIO $ getCurrentDirectory + let templatePath = (takeDirectory $ pwd filename) templateName + body <- runIO $ readFile templatePath + return (newPos templateName 1 1, body) + +parseInQ :: ParserQ v -> (SourcePos, String) -> Q v +parseInQ p (pos, s) = do + parseResult <- runParserT (inPosition p) () "" s + case parseResult of + Right v -> return v + Left err -> fail $ show err + where + inPosition :: ParserQ v -> ParserQ v + inPosition p' = do + setPosition pos + val <- p' + eof + return val + +parseDecls :: (SourcePos, String) -> Q [Decl] +parseDecls = parseInQ $ many1 $ + (DatatypeDecl <$> datatypeParser) <|> + (RepackerDecl <$> repackerParser) + +datatypeParser :: ParserQ Datatype +datatypeParser = do + _ <- optional endofline + typeName <- identifier + _ <- endofline + typeConstrs <- many1 constrParser + _ <- many endofline + + return Datatype {..} + +spaces :: Stream s m Char => ParsecT s u m () +spaces = skipMany1 (oneOf "\t ") + +constrParser :: ParserQ DataConstructor +constrParser = do + _ <- try (string " " "constructor padding") + constrName <- identifier + constrPrefix <- optionMaybe (try $ spaces *> prefix) + _ <- endofline + constrFields <- many1 constFieldParser + + return DataConstructor {..} + +repeatFactor :: ParserQ Int +repeatFactor = try (decimal <* char 'x') "repetition factor" + +constFieldParser :: ParserQ DataField +constFieldParser = do + _ <- try (string " ") "field padding" + fieldRepeat <- optionMaybe (try $ repeatFactor <* spaces) + fieldName <- fieldNameParser + _ <- spaces + fieldStrict <- try (char '!' *> return True <* spaces) <|> return False + fieldType <- typeParser + _ <- spaces + signed <- option False (True <$ char '+') + fieldWidth <- decimal "field width spec" + fieldParser <- fieldParserParser signed + _ <- endofline + return DataField {..} + +fieldNameParser :: ParserQ (Maybe String) +fieldNameParser = + (Just <$> identifier) <|> (Nothing <$ (char '_' <* identifier)) + +typeParser :: ParserQ Type +typeParser = (singleWord <|> multiWord) "field type" + where + singleWord = (TH.ConT . TH.mkName) <$> ((:) <$> letter <*> many alphaNum) + multiWord = error "multiWord is not yet implemented" + +fieldParserParser :: Bool -> ParserQ ParserType +fieldParserParser signed = + (if signed then pure SignedParser else fail "signed parser") <|> + (CustomParser <$> try (spaces *> customParser)) <|> + (HardcodedString <$> try (spaces *> hardcodedString)) <|> + (pure UnsignedParser) + +customParser :: ParserQ Exp +customParser = singleWord "custom parser" + where + singleWord = (TH.VarE . TH.mkName) <$> + ((:) <$> lower <*> many1 (noneOf "( )\t\n")) + +hardcodedString :: ParserQ String +hardcodedString = + between (char '"') (char '"') (many1 $ escapedChar <|> notQuote) + "hardcoded string" + where + escapedChar = char '\\' *> (special <|> hex <|> dec) + + special :: ParserQ Char + special = do + c <- oneOf "nt\"\\" + return $ case c of + 'n' -> '\n' + 't' -> '\t' + v -> v -- unescape for \" and \\ + + hex :: ParserQ Char + hex = char 'x' *> ((chr . read . ("0x"++)) <$> many1 hexDigit) + + dec :: ParserQ Char + dec = chr <$> decimal + + notQuote = noneOf ['"'] + +repackerParser :: ParserQ Repacker +repackerParser = Repacker + <$> parseRepackerName + <* spaces + <*> identifier + <* endofline + <*> many1 parseRepackerField + <* many endofline + +parseRepackerName :: ParserQ String +parseRepackerName = do + name <- many1 alphaNum + unless ("repackerFor" `isPrefixOf` name) $ fail $ + "Repacker name must start with \"repackerFor\": " ++ name + return name + +parseRepackerField :: ParserQ RepackerField +parseRepackerField = RepackerField + <$ (try (string " ") "repacker field padding") + <*> identifier + <*> optionMaybe (spaces *> customParser) + <* endofline + +decimal :: ParserQ Int +decimal = read <$> many1 digit + +identifier :: ParserQ String +identifier = ((:) <$> upper <*> many alphaNum) + +prefix :: ParserQ String +prefix = ((:) <$> lower <*> many alphaNum) + +endofline :: ParserQ [Char] +endofline = many1 + (try $ many (oneOf "\t ") *> (option "" $ try comment) *> char '\n') + "end of line" + where + comment = string "--" *> many1 (noneOf "\n") diff --git a/src/ParserGen/Parser.hs b/src/ParserGen/Parser.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Parser.hs @@ -0,0 +1,171 @@ +-- | Based on Data.Attoparsec.Zepto by Bryan O'Sullivan 2011 +-- +-- A tiny, highly specialized combinator parser for 'B.ByteString' +-- strings. Designed to split bytestrings into fields with fixed widths. +-- +-- unsafe versions of the functions do not perform checks that there +-- is enough data left in the bytestring +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +module ParserGen.Parser + ( Parser + , parse + , ensureBytesLeft + , atEnd + , string + , take + , unsafeTake + , skip + , unsafeSkip + , takeWhile + ) where + +import Data.Word (Word8) +import Control.Applicative +import Control.Monad +import Data.Monoid +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import Data.ByteString (ByteString) +import Prelude hiding (take, takeWhile) + +newtype S = S { + input :: ByteString + } + +data Result a = Fail String + | OK !a + +-- | A simple parser. +-- +-- This monad is strict in its state, and the monadic bind operator +-- ('>>=') evaluates each result to weak head normal form before +-- passing it along. +newtype Parser a = Parser { + runParser :: S -> (# Result a, S #) + } + +instance Functor Parser where + fmap f m = Parser $ \s -> case runParser m s of + (# OK a, s' #) -> (# OK (f a), s' #) + (# Fail err, s' #) -> (# Fail err, s' #) + {-# INLINE fmap #-} + +instance Monad Parser where + return a = Parser $ \s -> (# OK a, s #) + {-# INLINE return #-} + + m >>= k = Parser $ \s -> case runParser m s of + (# OK a, s' #) -> runParser (k a) s' + (# Fail err, s' #) -> (# Fail err, s' #) + {-# INLINE (>>=) #-} + + fail msg = Parser $ \s -> (# Fail msg, s #) + +instance MonadPlus Parser where + mzero = fail "mzero" + {-# INLINE mzero #-} + + mplus a b = Parser $ \s -> + case runParser a s of + (# ok@(OK _), s' #) -> (# ok, s' #) + (# _, _ #) -> case runParser b s of + (# ok@(OK _), s'' #) -> (# ok, s'' #) + (# err, s'' #) -> (# err, s'' #) + {-# INLINE mplus #-} + +instance Applicative Parser where + pure = return + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +gets :: (S -> a) -> Parser a +gets f = Parser $ \s -> (# OK (f s), s #) +{-# INLINE gets #-} + +put :: S -> Parser () +put s = Parser $ \_ -> (# OK (), s #) +{-# INLINE put #-} + +-- | Run a parser. +parse :: Parser a -> ByteString -> Either String a +parse p bs = case runParser p (S bs) of + (# OK a, _ #) -> Right a + (# Fail err, _ #) -> Left err +{-# INLINE parse #-} + +instance Monoid (Parser a) where + mempty = fail "mempty" + {-# INLINE mempty #-} + mappend = mplus + {-# INLINE mappend #-} + +instance Alternative Parser where + empty = fail "empty" + {-# INLINE empty #-} + (<|>) = mplus + {-# INLINE (<|>) #-} + +-- | Consume input while the predicate returns 'True'. +takeWhile :: (Word8 -> Bool) -> Parser ByteString +takeWhile p = do + (h,t) <- gets (B.span p . input) + put (S t) + return h +{-# INLINE takeWhile #-} + +-- | Consume @n@ bytes of input. +take :: Int -> Parser ByteString +take !n = do + s <- gets input + if B.length s >= n + then put (S (B.unsafeDrop n s)) >> return (B.unsafeTake n s) + else fail "insufficient input for take" +{-# INLINE take #-} + +ensureBytesLeft :: Int -> Parser () +ensureBytesLeft l = do + s <- gets input + if B.length s == l + then return () + else fail $ "Unexpected length: expected " ++ show l ++ + ", but got " ++ show (B.length s) +{-# INLINE ensureBytesLeft #-} + +-- | Consume @n@ bytes of input without checking if it's available +unsafeTake :: Int -> Parser ByteString +unsafeTake !n = do + s <- gets input + put (S (B.unsafeDrop n s)) + return (B.unsafeTake n s) +{-# INLINE unsafeTake #-} + +-- | Skip @n@ bytes of input +skip :: Int -> Parser () +skip !n = do + s <- gets input + if B.length s >= n + then put (S (B.unsafeDrop n s)) + else fail "insufficient input for skip" +{-# INLINE skip #-} + +-- | Skip @n@ bytes of input without checking if it's available +unsafeSkip :: Int -> Parser () +unsafeSkip !n = gets input >>= put . S . B.unsafeDrop n +{-# INLINE unsafeSkip #-} + +-- | Match a string exactly. +string :: ByteString -> Parser () +string s = do + i <- gets input + if s `B.isPrefixOf` i + then put (S (B.unsafeDrop (B.length s) i)) + else fail $ "string" +{-# INLINE string #-} + +-- | Indicate whether the end of the input has been reached. +atEnd :: Parser Bool +atEnd = do + i <- gets input + return $! B.null i +{-# INLINE atEnd #-} diff --git a/src/ParserGen/Repack.hs b/src/ParserGen/Repack.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Repack.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Repack + ( genRepackFromFile + ) where + +import Control.Applicative +import Control.Monad (foldM) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List (find) +import Data.Maybe (fromMaybe) +import Language.Haskell.TH + +import ParserGen.Auto +import ParserGen.ParseQuote +import ParserGen.Types + +genRepackFromFile :: FilePath -> Q [Dec] +genRepackFromFile templateName = do + (dts, rs) <- unzipDecls <$> getDecls templateName + fmap concat $ mapM (mkRepacker dts) rs + +mkRepacker :: [Datatype] -> Repacker -> Q [Dec] +mkRepacker dts (Repacker rname cname cfields) = do + withNames <- mapM (\cf -> (,) cf <$> newName "p") cfields + repackCmds <- mkRepackCmds dc withNames + + bsVar <- newName "bs" + undef <- [|undefined|] + btbT <- [t|ByteString -> ByteString|] + foldInit <- [|($(varE bsVar) , [])|] + fold <- foldM executeRepackCmd foldInit repackCmds + result <- [|B.concat $ snd $(return fold)|] + resultVar <- newName "result" + + validLen <- [|B.length $(varE resultVar) == $(litE $ integerL len)|] + otherwise' <- [|otherwise|] + + return + [ SigD repackerName (foldr mkType btbT cfields) + , FunD repackerName + [ Clause + (map (VarP . snd) withNames ++ [VarP bsVar]) + (GuardedB + -- Return original BS if length test fails. Note that we + -- only check the total length, where we actually also could + -- check the length of each field... + [ (NormalG validLen, VarE resultVar) + , (NormalG otherwise', VarE bsVar) + ]) + [ValD (VarP resultVar) (NormalB result) []] + ] + ] + where + repackerName = mkName rname + len = fromIntegral $ getConstructorWidth dc + + dc = case [c | dt <- dts, c <- typeConstrs dt, constrName c == cname] of + [x] -> x + _ -> error $ "No genparser for constructor " ++ cname + + mkType (RepackerField name _) t = + AppT (AppT ArrowT (getFieldType name dc)) t + +getFieldType :: String -> DataConstructor -> Type +getFieldType n dc = + case [getFieldRepeatType f | f <- constrFields dc, fieldName f == Just n] of + [t] -> t + _ -> error $ constrName dc ++ " has no field " ++ n + +data RepackCmd + = Skip Int + | Repack DataField Exp Name + deriving (Show) + +fuseSkips :: [RepackCmd] -> [RepackCmd] +fuseSkips (Skip a : Skip b : rcs) = fuseSkips $ Skip (a + b) : rcs +fuseSkips (r : rcs) = r : fuseSkips rcs +fuseSkips [] = [] + +mkRepackCmds :: DataConstructor -> [(RepackerField, Name)] -> Q [RepackCmd] +mkRepackCmds dc repacks = fmap fuseSkips $ mapM mkRepackCmd $ constrFields dc + where + mkRepackCmd :: DataField -> Q RepackCmd + mkRepackCmd df@(DataField {..}) = + case find ((== fieldName) . Just . repackerFieldName . fst) repacks of + Nothing -> return $ Skip $ getFieldWidth df + Just (rf, n) -> do + -- Try to automatically derive an unparser with the optionally + -- custom-specified one + (_, unparser) <- getFieldParserUnparser df + (repackerFieldUnparser rf) + + -- Compose the two + let unparser' = fromMaybe + (error $ "No unparser found for " ++ show fieldName) + unparser + + return $ Repack df unparser' n + +executeRepackCmd :: Exp -> RepackCmd -> Q Exp +executeRepackCmd e (Skip n) = + [| let (s, ps) = $(return e) + (this, next) = B.splitAt n s + in (next, ps ++ [this]) |] +executeRepackCmd e (Repack df f name) = do + [| let (s, ps) = $(return e) + (_, next) = B.splitAt n s + in (next, ps ++ $(return f) $(return $ VarE name)) |] + where + n = getFieldWidth df + r = getFieldHasRepeat df diff --git a/src/ParserGen/Types.hs b/src/ParserGen/Types.hs new file mode 100644 --- /dev/null +++ b/src/ParserGen/Types.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE RecordWildCards #-} +module ParserGen.Types + ( Decl (..) + , unzipDecls + + , Datatype (..) + + , DataConstructor (..) + , getConstructorWidth + + , DataField (..) + , getFieldWidth + , getFieldRepeatType + , getFieldHasRepeat + , getFieldIsIgnored + + , ParserType (..) + + , Repacker (..) + , RepackerField (..) + ) where + +import Data.Maybe (isJust, isNothing) +import Language.Haskell.TH (Exp, Type (..)) + +data Decl + = DatatypeDecl Datatype + | RepackerDecl Repacker + deriving (Show) + +unzipDecls :: [Decl] -> ([Datatype], [Repacker]) +unzipDecls decls = + ( [d | DatatypeDecl d <- decls] + , [r | RepackerDecl r <- decls] + ) + +data Datatype + = Datatype + { typeName :: String + , typeConstrs :: [DataConstructor] + } deriving (Show) + +data DataConstructor + = DataConstructor + { constrName :: String + , constrPrefix :: Maybe String + , constrFields :: [DataField] + } deriving (Show) + +getConstructorWidth :: DataConstructor -> Int +getConstructorWidth = sum . map getFieldWidth . constrFields + +data DataField + = DataField + { fieldName :: Maybe String + , fieldRepeat :: Maybe Int + , fieldType :: Type + , fieldStrict :: Bool + , fieldWidth :: Int + , fieldParser :: ParserType + } deriving (Show) + +-- get size to skip taking into account its repetition and sign if exists +getFieldWidth :: DataField -> Int +getFieldWidth (DataField {..}) = + let width = fieldWidth + if fieldParser == SignedParser then 1 else 0 + times = maybe 1 id fieldRepeat + in width * times + +getFieldRepeatType :: DataField -> Type +getFieldRepeatType df + | getFieldHasRepeat df = AppT ListT $ fieldType df + | otherwise = fieldType df + +getFieldHasRepeat :: DataField -> Bool +getFieldHasRepeat = isJust . fieldRepeat + +getFieldIsIgnored :: DataField -> Bool +getFieldIsIgnored = isNothing . fieldName + +data ParserType + = CustomParser Exp -- user provided parser, ex: issue + | UnsignedParser -- type/newtype wrapper around supported datatypes + | SignedParser -- type/newtype wrapper around numerical datatypes only + | HardcodedString String -- raw string, ex "B7014" + deriving (Show, Eq) + +data Repacker = Repacker + { repackerName :: String + , repackerConstructor :: String + , repackerFields :: [RepackerField] + } deriving (Show) + +data RepackerField = RepackerField + { repackerFieldName :: String + , repackerFieldUnparser :: Maybe Exp + } deriving (Show) diff --git a/tests/ParserGen/Common/Tests.hs b/tests/ParserGen/Common/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/ParserGen/Common/Tests.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Common.Tests + ( tests + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Gen (elements) + +import ParserGen.Common +import ParserGen.Parser + +tests :: Test +tests = testGroup "ParserGen.Common.Tests" + [ testProperty "decimalX" testDecimalX + , testProperty "decimalX (TH)" testDecimalXTH + , testProperty "decimalXS" testDecimalXS + , testProperty "decimalXS (TH)" testDecimalXSTH + , testProperty "alphaNum" testAlphaNum + ] + +newtype DecimalX = DecimalX Int + deriving (Eq, Show) + +instance Arbitrary DecimalX where + arbitrary = DecimalX . (flip mod 1000000) . abs <$> arbitrary + +testDecimalX :: DecimalX -> Bool +testDecimalX (DecimalX x) = + parse (unsafeDecimalX 6) (putDecimalX 6 x) == Right x + +testDecimalXTH :: DecimalX -> Bool +testDecimalXTH (DecimalX x) = + parse $(unsafeDecimalXTH 6) (putDecimalX 6 x) == Right x + +newtype DecimalXS = DecimalXS Int + deriving (Eq, Show) + +instance Arbitrary DecimalXS where + arbitrary = do + DecimalX x <- arbitrary + neg <- arbitrary + return $ DecimalXS $ if neg then negate x else x + +testDecimalXS :: DecimalXS -> Bool +testDecimalXS (DecimalXS x) = + parse (unsafeDecimalXS 6) (putDecimalXS 6 x) == Right x + +testDecimalXSTH :: DecimalXS -> Bool +testDecimalXSTH (DecimalXS x) = + parse $(unsafeDecimalXSTH 6) (putDecimalXS 6 x) == Right x + +newtype AlphaNumTest = AlphaNumTest ByteString + deriving (Eq, Show) + +instance Arbitrary AlphaNumTest where + arbitrary = AlphaNumTest . BC.pack <$> replicateM 12 (elements chars) + where + chars = (['A' .. 'Z'] ++ ['0' .. '9']) + +testAlphaNum :: AlphaNumTest -> Bool +testAlphaNum (AlphaNumTest bs) = + either error putAlphaNum (parse (unsafeAlphaNum 12) bs) == bs diff --git a/tests/ParserGen/Tests.hs b/tests/ParserGen/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/ParserGen/Tests.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +module ParserGen.Tests + ( tests + ) where + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, (@=?)) + +import ParserGen.Parser +import ParserGen.Tests.Packet + +tests :: Test +tests = testGroup "ParserGen.Tests" + [ testCase "parse sampleWarning" testParseSampleWarning + , testCase "parse sampleLotteryWin" testParseSampleLotteryWin + , testCase "parse sampleMessage" testParseSampleMessage + , testCase "width sampleMessage" testWidthForMessage + , testCase "repackerForWarning" testRepackerForWarning + , testCase "repackerForLotteryWin" testRepackerForLotteryWin + , testCase "testRepackerForMessage" testRepackerForMessage + ] + +testParseSampleWarning :: Assertion +testParseSampleWarning = + -- A 'RobotUprising' with only 2 percent of survival?! At least it's not an + -- 'AngryGirlfriend'... + Right (Warning RobotUprising 2) @=? + parse parserForPacket sampleWarning + +testParseSampleLotteryWin :: Assertion +testParseSampleLotteryWin = + Right (LotteryWin (Money 9999999999) [4, 8, 15, 16, 23, 42]) @=? + parse parserForPacket sampleLotteryWin + +testParseSampleMessage :: Assertion +testParseSampleMessage = + Right (Message "CATS " (-20) "ALL YOUR BASE ARE BELONG TO US ") @=? + parse parserForMessage sampleMessage + +testWidthForMessage :: Assertion +testWidthForMessage = 62 @=? widthForMessage + +testRepackerForWarning :: Assertion +testRepackerForWarning = + "WARNZA002" @=? repackerForWarning ZombieApocalypse sampleWarning + +testRepackerForLotteryWin :: Assertion +testRepackerForLotteryWin = case parse parserForPacket packet' of + Left err -> fail err + Right x -> [1 .. 6] @=? lwWinningEntry x + where + packet' = repackerForLotteryWin [1 .. 6] sampleLotteryWin + +testRepackerForMessage :: Assertion +testRepackerForMessage = + "MESSGLADOS IMPORTANT 0945-020PLEASE CONTINUE TESTING " @=? + repackerForMessage "GLADOS " "PLEASE CONTINUE TESTING " + sampleMessage diff --git a/tests/ParserGen/Tests/Packet.hs b/tests/ParserGen/Tests/Packet.hs new file mode 100644 --- /dev/null +++ b/tests/ParserGen/Tests/Packet.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module ParserGen.Tests.Packet + ( DangerType (..) + , Money (..) + , LotteryEntry + , MessageBody (..) + + , Packet (..) + , parserForWarning + , parserForLotteryWin + , parserForMessage + , parserForPacket + + , widthForWarning + , widthForLotteryWin + , widthForMessage + + , repackerForWarning + , repackerForLotteryWin + , repackerForMessage + + , sampleWarning + , sampleLotteryWin + , sampleMessage + ) where + +import Control.Applicative ((<|>)) +import Data.ByteString (ByteString) +import GHC.Exts (IsString) +import ParserGen.Gen +import ParserGen.Repack +import qualified ParserGen.Parser as P + +data DangerType + = Earthquake + | ZombieApocalypse + | RobotUprising + | AngryGirlfriend + deriving (Eq, Show) + +dangerType :: P.Parser DangerType +dangerType = do + bs <- P.take 2 + case bs of + "EQ" -> return Earthquake + "ZA" -> return ZombieApocalypse + "RI" -> return RobotUprising + "AG" -> return AngryGirlfriend + _ -> fail $ "Unknown danger type: " ++ show bs + +unDangerType :: DangerType -> ByteString +unDangerType Earthquake = "EQ" +unDangerType ZombieApocalypse = "ZA" +unDangerType RobotUprising = "RI" +unDangerType AngryGirlfriend = "AG" + +newtype Money = Money Int + deriving (Eq, Show) + +type LotteryEntry = Int + +newtype MessageBody = MessageBody ByteString + deriving (Eq, IsString, Show) + +$(genDataTypeFromFile "Packet.ths") +$(genParserFromFile "Packet.ths") +$(genWidthFromFile "Packet.ths") +$(genRepackFromFile "Packet.ths") + +parserForPacket :: P.Parser Packet +parserForPacket = parserForWarning <|> parserForLotteryWin <|> parserForMessage + +sampleWarning :: ByteString +sampleWarning = "WARNRI002" + +sampleLotteryWin :: ByteString +sampleLotteryWin = "LOTT9999999999040815162342" + +sampleMessage :: ByteString +sampleMessage = "MESSCATS IMPORTANT 0945-020ALL YOUR BASE ARE BELONG TO US " diff --git a/tests/ParserGen/Tests/Packet.ths b/tests/ParserGen/Tests/Packet.ths new file mode 100644 --- /dev/null +++ b/tests/ParserGen/Tests/Packet.ths @@ -0,0 +1,29 @@ +Packet + Warning + _PacketType ByteString 4 "WARN" + DangerType DangerType 2 dangerType + ChanceOfSurvival Int 3 + + LotteryWin + _PacketType ByteString 4 "LOTT" + Amount Money 10 + 6x WinningEntry LotteryEntry 2 + + Message + _PacketType ByteString 4 "MESS" + Sender ByteString 8 + _Subject ByteString 10 + _TimeHour Int 2 + _TimeMinute Int 2 + Temperature Int +3 + Body MessageBody 32 + +repackerForWarning Warning + DangerType unDangerType + +repackerForLotteryWin LotteryWin + WinningEntry + +repackerForMessage Message + Sender + Body diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,14 @@ +module Main + ( main + ) where + +import Test.Framework (defaultMain) + +import qualified ParserGen.Common.Tests +import qualified ParserGen.Tests + +main :: IO () +main = defaultMain + [ ParserGen.Common.Tests.tests + , ParserGen.Tests.tests + ]