tools/protocolParser.hs
author unc0rr
Wed, 13 May 2015 23:21:40 +0300
branchqmlfrontend
changeset 10929 8ebf01f75d9f
parent 10927 336f5ad638be
child 10931 384765cd0caf
permissions -rw-r--r--
Mockup of protocol parser
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     1
module Main where
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     2
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     3
import Text.PrettyPrint.HughesPJ
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
     4
import qualified Data.MultiMap as MM
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
     5
import Data.Maybe
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
     6
import Data.List
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
     7
import Data.Char
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     8
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     9
data HWProtocol = Command String [CmdParam]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    10
data CmdParam = Skip
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    11
              | SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    12
              | LS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    13
              | IntP
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    14
              | Many [CmdParam]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    15
data ClientStates = NotConnected
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    16
                  | JustConnected
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    17
                  | ServerAuth
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    18
                  | Lobby
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    19
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    20
data ParseTree = PTPrefix String [ParseTree]
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    21
               | PTCommand String HWProtocol
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
    22
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    23
cmd = Command
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    24
cmd1 s p = Command s [p]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    25
cmd2 s p1 p2 = Command s [p1, p2]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    26
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    27
breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params)
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
    28
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    29
commands = [
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    30
        cmd "CONNECTED" [Skip, IntP]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    31
        , cmd1 "NICK" SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    32
        , cmd1 "PROTO" IntP
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    33
        , cmd1 "ASKPASSWORD" SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    34
        , cmd1 "SERVER_AUTH" SS
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    35
        , cmd1 "JOINING" SS
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    36
        , cmd1 "TEAM_ACCEPTED" SS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    37
        , cmd1 "HH_NUM" $ Many [SS]
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    38
        , cmd1 "TEAM_COLOR" $ Many [SS]
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    39
        , cmd1 "TEAM_ACCEPTED" SS
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    40
        , cmd1 "BANLIST" $ Many [SS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    41
        , cmd1 "JOINED" $ Many [SS]
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    42
        , cmd1 "LOBBY:JOINED" $ Many [SS]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    43
        , cmd2 "LOBBY:LEFT" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    44
        , cmd2 "CLIENT_FLAGS" SS $ Many [SS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    45
        , cmd2 "LEFT" SS $ Many [SS]
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
    46
        , cmd1 "SERVER_MESSAGE" LS
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    47
        , cmd1 "ERROR" LS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    48
        , cmd1 "NOTICE" LS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    49
        , cmd1 "WARNING" LS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    50
        , cmd1 "JOINING" SS
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    51
        , cmd1 "EM" $ Many [LS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    52
        , cmd1 "PING" $ Many [SS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    53
        , cmd2 "CHAT" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    54
        , cmd2 "SERVER_VARS" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    55
        , cmd2 "BYE" SS LS
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
    56
        , cmd1 "INFO" $ Many [SS]
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    57
        , cmd1 "ROOMS" $ Many [SS]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    58
        , cmd "KICKED" []
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    59
        , cmd "RUN_GAME" []
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    60
        , cmd "ROUND_FINISHED" []
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    61
    ]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    62
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    63
unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]]
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    64
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    65
groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    66
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
    67
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    68
makePT cmd@(Command n p) = PTCommand n cmd
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    69
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    70
buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]]
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
    71
bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    72
    where
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    73
        emptyNamed = find (\(_, (PTCommand n _:_)) -> null n) assocs
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    74
        assocs = groupByFirstChar cmds
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    75
        subtree = map buildsub assocs
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
    76
        buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    77
        maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    78
        maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    79
        cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [hwc]]
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    80
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    81
dumpTree = vcat . map dt
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    82
    where
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    83
    dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st)
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    84
    dt _ = empty
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    85
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
    86
pas2 = buildSwitch $ buildParseTree commands
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    87
    where
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    88
        buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    89
        buildCase (PTCommand {}) = text "#10: <call cmd handler>;"
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    90
        buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds)
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    91
        consumePrefix "" = id
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    92
        consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$)
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    93
        zeroChar = text "#0: state:= pstDisconnected;"
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    94
        elsePart = text "else <unknown cmd> end;"
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    95
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    96
renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c]
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
    97
    where
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
    98
        maybeQuotes s = if null $ tail s then quotes $ text s else text s
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
    99
        l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = "
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   100
            <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   101
        s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = "
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   102
            <> parens (hsep . punctuate comma $ map text commands) <> semi
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   103
        c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = "
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   104
            <> parens (hsep . punctuate comma $ map (text . (++) "@handler_") $ reverse fixedNames) <> semi
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   105
        fixedNames = map fixName handlers
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   106
        fixName = map fixChar
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   107
        fixChar c | isLetter c = c
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   108
                  | otherwise = '_'
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   109
        bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   110
        handlerBody n = text "procedure handler_" <> text n <> semi
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   111
            $+$ text "begin" 
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   112
            $+$ nest 4 (
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   113
                text "state.cmd:= cmd_" <> text n <> semi
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   114
            )
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   115
            $+$ text "end" <> semi
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   116
        cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) fixedNames) <> semi
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
   117
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   118
pas = renderArrays $ buildTables $ buildParseTree commands
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   119
    where
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   120
        buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3)
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   121
        walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) =
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   122
            (lc, 2:sh, pc - 1, "#10":"#0":tbl1, "0":show pc:tbl2, (n:t3):tbl3)
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   123
        walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   124
        lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3)
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   125
        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)
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   126
        fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3)
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   127
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   128
main = putStrLn $ renderStyle style{lineLength = 80} pas