packages feed

parsergen (empty) → 0.2.0.0

raw patch · 17 files changed

+1491/−0 lines, 17 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, directory, filepath, parsec, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

+ LICENSE view
@@ -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.
+ README.markdown view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ parsergen.cabal view
@@ -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:+  .+  <https://github.com/tsurucapital/parsergen/blob/master/README.markdown>++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
+ src/ParserGen.hs view
@@ -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
+ src/ParserGen/Auto.hs view
@@ -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
+ src/ParserGen/Common.hs view
@@ -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 #-}
+ src/ParserGen/Gen.hs view
@@ -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
+ src/ParserGen/ParseQuote.hs view
@@ -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")
+ src/ParserGen/Parser.hs view
@@ -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 #-}
+ src/ParserGen/Repack.hs view
@@ -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
+ src/ParserGen/Types.hs view
@@ -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)
+ tests/ParserGen/Common/Tests.hs view
@@ -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
+ tests/ParserGen/Tests.hs view
@@ -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
+ tests/ParserGen/Tests/Packet.hs view
@@ -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  "
+ tests/ParserGen/Tests/Packet.ths view
@@ -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
+ tests/TestSuite.hs view
@@ -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+    ]