tools/protocolParser.hs
author unc0rr
Tue, 24 Nov 2015 20:19:00 +0300
branchqmlfrontend
changeset 11434 d96a37de1076
parent 11433 cc12bba5b2a2
child 11446 908aed8525f9
permissions -rw-r--r--
Apply generated code to .pas files, fix FULLMAPCONFIG handling

module Main where

import Text.PrettyPrint.HughesPJ
import qualified Data.MultiMap as MM
import Data.Maybe
import Data.List
import Data.Char
import qualified Data.Set as Set

data HWProtocol = Command String [CmdParam]
    deriving Show

instance Ord HWProtocol where
    (Command a _) `compare` (Command b _) = a `compare` b    
instance Eq HWProtocol where
    (Command a _) == (Command b _) = a == b

data CmdParam = Skip
              | SS
              | LS
              | IntP
              | Many [CmdParam]
    deriving Show

data ParseTree = PTPrefix String [ParseTree]
               | PTCommand String HWProtocol
    deriving Show

cmd = Command
cmd1 s p = Command s [p]
cmd2 s p1 p2 = Command s [p1, p2]

cmdName (Command n _) = n

cmdParams2str (Command _ p) = "TCmdParam" ++ concatMap f p
    where
    f Skip = ""
    f SS = "S"
    f LS = "L"
    f IntP = "i"
    f (Many p) = ""

cmdParams2handlerType (Command _ p) = "handler_" ++ concatMap f p
    where
    f Skip = "_"
    f SS = "S"
    f LS = "L"
    f IntP = "i"
    f (Many p) = 'M' : concatMap f p

cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ 
    text "type " <> text (cmdParams2str cmd)
    <> text " = record" $+$ nest 4 (
    vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) 
    $+$ text "end;")
    where
    isRendered Skip = False
    isRendered (Many _) = False
    isRendered _ = True
    f n Skip = empty
    f n SS = text "str" <> int n <> text ": shortstring;"
    f n LS = text "str" <> int n <> text ": longstring;"
    f n IntP = text "param" <> int n <> text ": LongInt;"
    f _ (Many _) = empty

commandsDescription = [
        cmd "CONNECTED" [Skip, IntP]
        , cmd1 "NICK" SS
        , cmd1 "PROTO" IntP
        , cmd1 "ASKPASSWORD" SS
        , cmd1 "SERVER_AUTH" SS
        , cmd1 "JOINING" SS
        , cmd1 "TEAM_ACCEPTED" SS
        , cmd1 "HH_NUM" $ Many [SS]
        , cmd1 "TEAM_COLOR" $ Many [SS]
        , cmd1 "BANLIST" $ Many [SS]
        , cmd1 "JOINED" $ Many [SS]
        , cmd1 "LOBBY:JOINED" $ Many [SS]
        , cmd2 "LOBBY:LEFT" SS LS
        , cmd2 "CLIENT_FLAGS" SS $ Many [SS]
        , cmd2 "LEFT" SS $ Many [SS]
        , cmd1 "SERVER_MESSAGE" LS
        , cmd1 "ERROR" LS
        , cmd1 "NOTICE" LS
        , cmd1 "WARNING" LS
        , cmd1 "EM" $ Many [LS]
        , cmd1 "PING" $ Many [SS]
        , cmd2 "CHAT" SS LS
        , cmd2 "SERVER_VARS" SS LS
        , cmd2 "BYE" SS LS
        , cmd1 "INFO" $ Many [SS]
        , cmd1 "ROOM~ADD" $ Many [SS]
        , cmd1 "ROOM~UPD" $ Many [SS]
        , cmd1 "ROOM~DEL" SS
        , cmd1 "ROOMS" $ Many [SS]
        , cmd "KICKED" []
        , cmd "RUN_GAME" []
        , cmd "ROUND_FINISHED" []
        , cmd1 "ADD_TEAM" $ Many [SS]
        , cmd1 "REMOVE_TEAM" SS
        , cmd1 "CFG~MAP" SS
        , cmd1 "CFG~SEED" SS
        , cmd1 "CFG~SCHEME" $ Many [SS]
        , cmd1 "CFG~THEME" SS
        , cmd1 "CFG~TEMPLATE" IntP
        , cmd1 "CFG~MAPGEN" IntP
        , cmd1 "CFG~FEATURE_SIZE" IntP
        , cmd1 "CFG~MAZE_SIZE" IntP
        , cmd1 "CFG~SCRIPT" SS
        , cmd1 "CFG~DRAWNMAP" LS
        , cmd2 "CFG~AMMO" SS LS
        , cmd1 "CFG~FULLMAPCONFIG" $ Many [LS]
    ]

hasMany = any isMany
isMany (Many _) = True
isMany _ = False

unknown = Command "__UNKNOWN__" [Many [SS]]
unknowncmd = PTPrefix "$" [PTCommand "$" $ unknown]

fixName = map fixChar
fixChar c | isLetter c = c
          | otherwise = '_'

groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])]
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
    where
    breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params)

makePT cmd@(Command n p) = PTCommand n cmd

buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]]

bpt :: [ParseTree] -> [ParseTree]
bpt cmds = cmdLeaf emptyNamed
    where
        emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) $ groupByFirstChar cmds
        buildsub :: (Char, [ParseTree]) -> [ParseTree] -> ParseTree
        buildsub (c, cmds) pc = let st = (bpt cmds) ++ pc in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st
        buildsub' = flip buildsub []
        cmdLeaf ([], assocs) = map buildsub' assocs
        cmdLeaf ([(c, hwc:assocs1)], assocs2)
            | null assocs1 = PTPrefix [c] [hwc] : map buildsub' assocs2
            | otherwise = (buildsub (c, assocs1) [hwc]) : map buildsub' assocs2

        maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd
        maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss
        maybeMerge c [] = PTPrefix [c] []
        
dumpTree = vcat . map dt
    where
    dt (PTPrefix s st) = text s $$ (nest (length s) $ vcat $ map dt st)
    dt _ = char '$'

renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, l, s, c, bodies, structs, realHandlers, realHandlersArray, cmds]
    where
        maybeQuotes "$" = text "#0"
        maybeQuotes "~" = text "#10"
        maybeQuotes s = if null $ tail s then quotes $ text s else text s
        l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = "
            <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi
        s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = "
            <> parens (hsep . punctuate comma $ map text commands) <> semi
        c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = "
            <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi
        grr = text "const net2cmd: array[0.." <> (int $ length fixedNames - 1) <> text "] of TCmdType = "
            <> parens (hsep . punctuate comma $ map (text . (++) "cmd_") $ reverse fixedNames) <> semi
        handlerTypes = "handler__UNKNOWN_" : (map cmdParams2handlerType $ reverse sortedCmdDescriptions)
        sortedCmdDescriptions = sort commandsDescription
        fixedNames = map fixName handlers
        bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes
        handlerBody n = text "procedure " <> text n <> semi
            $+$ text "begin"
            $+$ text "end" <> semi
        cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi
        structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription)
        realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions
        realHandlersArray = text "const handlers: array[TCmdType] of PHandler = "
            <> parens (hsep . punctuate comma . concatMap (map ((<>) (text "PHandler") . parens) . rhentry "@handler_") $ sortedCmdDescriptions) <> semi

rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi
    $+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi
    , emptyBody] else empty
    where
        emptyBody = text "begin"  $+$ text "end" <> semi

rhentry prefix cmd@(Command n p) = (text . (++) prefix . fixName . cmdName $ cmd)
    : if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else []

pas = renderArrays $ buildTables $ buildParseTree commandsDescription
    where
        buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3)
        walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) =
            (lc, 1:sh, pc - 1, "#10":tbl1, show pc:tbl2, (n:t3):tbl3)
        walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix
        lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3)
        lvldown (lc, s1:s2:sh, pc, tbl1, t:tbl2, t31:t32:tbl3) = (lc, s1+s2:sh, pc, tbl1, (if null t32 then "0" else show s1):tbl2, (t31 ++ t32):tbl3)
        fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3)

main = do
    putStrLn $ renderStyle style{mode = ZigZagMode, lineLength = 80} $ pas
    --putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription