tools/protocolParser.hs
author unc0rr
Wed, 02 Dec 2015 22:30:13 +0300
branchqmlfrontend
changeset 11441 908aed8525f9
parent 11429 d96a37de1076
child 11442 6b04a266feee
permissions -rw-r--r--
Fix LEFT command handling
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
11047
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
     8
import qualified Data.Set as Set
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
     9
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    10
data HWProtocol = Command String [CmdParam]
11417
4815e406a760 Fix losing commands
unc0rr
parents: 11413
diff changeset
    11
    deriving Show
11048
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    12
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    13
instance Ord HWProtocol where
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    14
    (Command a _) `compare` (Command b _) = a `compare` b    
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    15
instance Eq HWProtocol where
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    16
    (Command a _) == (Command b _) = a == b
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    17
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    18
data CmdParam = Skip
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    19
              | SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    20
              | LS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    21
              | IntP
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    22
              | Many [CmdParam]
11417
4815e406a760 Fix losing commands
unc0rr
parents: 11413
diff changeset
    23
    deriving Show
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    24
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
    25
data ParseTree = PTPrefix String [ParseTree]
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
    26
               | PTCommand String HWProtocol
11417
4815e406a760 Fix losing commands
unc0rr
parents: 11413
diff changeset
    27
    deriving Show
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
cmd = Command
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    30
cmd1 s p = Command s [p]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    31
cmd2 s p1 p2 = Command s [p1, p2]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    32
11076
fcbdee9cdd74 more work
unc0rr
parents: 11075
diff changeset
    33
cmdName (Command n _) = n
fcbdee9cdd74 more work
unc0rr
parents: 11075
diff changeset
    34
11047
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    35
cmdParams2str (Command _ p) = "TCmdParam" ++ concatMap f p
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    36
    where
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    37
    f Skip = ""
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    38
    f SS = "S"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    39
    f LS = "L"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    40
    f IntP = "i"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    41
    f (Many p) = ""
11048
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    42
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    43
cmdParams2handlerType (Command _ p) = "handler_" ++ concatMap f p
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    44
    where
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    45
    f Skip = "_"
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    46
    f SS = "S"
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    47
    f LS = "L"
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    48
    f IntP = "i"
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
    49
    f (Many p) = 'M' : concatMap f p
11050
9b7c8c5a94e0 Some fixes
unc0rr
parents: 11048
diff changeset
    50
11047
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    51
cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ 
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    52
    text "type " <> text (cmdParams2str cmd)
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    53
    <> text " = record" $+$ nest 4 (
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    54
    vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) 
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    55
    $+$ text "end;")
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    56
    where
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    57
    isRendered Skip = False
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    58
    isRendered (Many _) = False
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    59
    isRendered _ = True
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    60
    f n Skip = empty
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    61
    f n SS = text "str" <> int n <> text ": shortstring;"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    62
    f n LS = text "str" <> int n <> text ": longstring;"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    63
    f n IntP = text "param" <> int n <> text ": LongInt;"
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    64
    f _ (Many _) = empty
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    65
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
    66
commandsDescription = [
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    67
        cmd "CONNECTED" [Skip, IntP]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    68
        , cmd1 "NICK" SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    69
        , cmd1 "PROTO" IntP
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    70
        , cmd1 "ASKPASSWORD" SS
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    71
        , cmd1 "SERVER_AUTH" SS
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    72
        , cmd1 "JOINING" SS
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    73
        , cmd1 "TEAM_ACCEPTED" SS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    74
        , cmd1 "HH_NUM" $ Many [SS]
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    75
        , cmd1 "TEAM_COLOR" $ Many [SS]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    76
        , cmd1 "BANLIST" $ Many [SS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    77
        , cmd1 "JOINED" $ Many [SS]
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
    78
        , cmd1 "LOBBY:JOINED" $ Many [SS]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    79
        , cmd2 "LOBBY:LEFT" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    80
        , cmd2 "CLIENT_FLAGS" SS $ Many [SS]
11441
908aed8525f9 Fix LEFT command handling
unc0rr
parents: 11429
diff changeset
    81
        , cmd2 "LEFT" SS LS
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
    82
        , cmd1 "SERVER_MESSAGE" LS
11050
9b7c8c5a94e0 Some fixes
unc0rr
parents: 11048
diff changeset
    83
        , cmd1 "ERROR" LS
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    84
        , cmd1 "NOTICE" LS
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    85
        , cmd1 "WARNING" LS
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    86
        , cmd1 "EM" $ Many [LS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    87
        , cmd1 "PING" $ Many [SS]
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    88
        , cmd2 "CHAT" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    89
        , cmd2 "SERVER_VARS" SS LS
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    90
        , cmd2 "BYE" SS LS
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
    91
        , cmd1 "INFO" $ Many [SS]
11425
2947f06e8533 Another approach to parsing two-lines protocol commands
unc0rr
parents: 11419
diff changeset
    92
        , cmd1 "ROOM~ADD" $ Many [SS]
2947f06e8533 Another approach to parsing two-lines protocol commands
unc0rr
parents: 11419
diff changeset
    93
        , cmd1 "ROOM~UPD" $ Many [SS]
2947f06e8533 Another approach to parsing two-lines protocol commands
unc0rr
parents: 11419
diff changeset
    94
        , cmd1 "ROOM~DEL" SS
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    95
        , cmd1 "ROOMS" $ Many [SS]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
    96
        , cmd "KICKED" []
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    97
        , cmd "RUN_GAME" []
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
    98
        , cmd "ROUND_FINISHED" []
11427
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
    99
        , cmd1 "ADD_TEAM" $ Many [SS]
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   100
        , cmd1 "REMOVE_TEAM" SS
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   101
        , cmd1 "CFG~MAP" SS
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   102
        , cmd1 "CFG~SEED" SS
11429
d96a37de1076 Apply generated code to .pas files, fix FULLMAPCONFIG handling
unc0rr
parents: 11428
diff changeset
   103
        , cmd1 "CFG~SCHEME" $ Many [SS]
11427
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   104
        , cmd1 "CFG~THEME" SS
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   105
        , cmd1 "CFG~TEMPLATE" IntP
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   106
        , cmd1 "CFG~MAPGEN" IntP
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   107
        , cmd1 "CFG~FEATURE_SIZE" IntP
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   108
        , cmd1 "CFG~MAZE_SIZE" IntP
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   109
        , cmd1 "CFG~SCRIPT" SS
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   110
        , cmd1 "CFG~DRAWNMAP" LS
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   111
        , cmd2 "CFG~AMMO" SS LS
11429
d96a37de1076 Apply generated code to .pas files, fix FULLMAPCONFIG handling
unc0rr
parents: 11428
diff changeset
   112
        , cmd1 "CFG~FULLMAPCONFIG" $ Many [LS]
10898
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
   113
    ]
f373838129c2 Some futher work on flib net client part
unc0rr
parents:
diff changeset
   114
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   115
hasMany = any isMany
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   116
isMany (Many _) = True
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   117
isMany _ = False
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   118
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   119
unknown = Command "__UNKNOWN__" [Many [SS]]
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   120
unknowncmd = PTPrefix "$" [PTCommand "$" $ unknown]
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   121
11075
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   122
fixName = map fixChar
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   123
fixChar c | isLetter c = c
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   124
          | otherwise = '_'
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   125
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   126
groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])]
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
   127
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
11050
9b7c8c5a94e0 Some fixes
unc0rr
parents: 11048
diff changeset
   128
    where
9b7c8c5a94e0 Some fixes
unc0rr
parents: 11048
diff changeset
   129
    breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params)
10902
29519fe63fdd Will use own tree type
unc0rr
parents: 10900
diff changeset
   130
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   131
makePT cmd@(Command n p) = PTCommand n cmd
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   132
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   133
buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]]
11428
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   134
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   135
bpt :: [ParseTree] -> [ParseTree]
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   136
bpt cmds = cmdLeaf emptyNamed
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
   137
    where
11428
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   138
        emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) $ groupByFirstChar cmds
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   139
        buildsub :: (Char, [ParseTree]) -> [ParseTree] -> ParseTree
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   140
        buildsub (c, cmds) pc = let st = (bpt cmds) ++ pc in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   141
        buildsub' = flip buildsub []
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   142
        cmdLeaf ([], assocs) = map buildsub' assocs
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   143
        cmdLeaf ([(c, hwc:assocs1)], assocs2)
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   144
            | null assocs1 = PTPrefix [c] [hwc] : map buildsub' assocs2
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   145
            | otherwise = (buildsub (c, assocs1) [hwc]) : map buildsub' assocs2
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   146
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   147
        maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
   148
        maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss
11419
8a5cc31483c6 - Handle ROOM DEL
unc0rr
parents: 11417
diff changeset
   149
        maybeMerge c [] = PTPrefix [c] []
11428
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   150
        
10906
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
   151
dumpTree = vcat . map dt
13fde38281fc Rendering some code
unc0rr
parents: 10904
diff changeset
   152
    where
11428
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   153
    dt (PTPrefix s st) = text s $$ (nest (length s) $ vcat $ map dt st)
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   154
    dt _ = char '$'
10904
ce265b038220 Some more work on network client implementation
unc0rr
parents: 10902
diff changeset
   155
11429
d96a37de1076 Apply generated code to .pas files, fix FULLMAPCONFIG handling
unc0rr
parents: 11428
diff changeset
   156
renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, l, s, c, bodies, structs, realHandlers, realHandlersArray, cmds]
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
   157
    where
11048
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
   158
        maybeQuotes "$" = text "#0"
11425
2947f06e8533 Another approach to parsing two-lines protocol commands
unc0rr
parents: 11419
diff changeset
   159
        maybeQuotes "~" = text "#10"
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   160
        maybeQuotes s = if null $ tail s then quotes $ text s else text s
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   161
        l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = "
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   162
            <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   163
        s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = "
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   164
            <> parens (hsep . punctuate comma $ map text commands) <> semi
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   165
        c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = "
11048
2edb24ed5ee0 Break it even more during refactoring
unC0Rr
parents: 11047
diff changeset
   166
            <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   167
        grr = text "const net2cmd: array[0.." <> (int $ length fixedNames - 1) <> text "] of TCmdType = "
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   168
            <> parens (hsep . punctuate comma $ map (text . (++) "cmd_") $ reverse fixedNames) <> semi
11429
d96a37de1076 Apply generated code to .pas files, fix FULLMAPCONFIG handling
unc0rr
parents: 11428
diff changeset
   169
        handlerTypes = "handler__UNKNOWN_" : (map cmdParams2handlerType $ reverse sortedCmdDescriptions)
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   170
        sortedCmdDescriptions = sort commandsDescription
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   171
        fixedNames = map fixName handlers
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   172
        bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   173
        handlerBody n = text "procedure " <> text n <> semi
11427
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   174
            $+$ text "begin"
10929
8ebf01f75d9f Mockup of protocol parser
unc0rr
parents: 10927
diff changeset
   175
            $+$ text "end" <> semi
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   176
        cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi
11047
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
   177
        structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription)
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   178
        realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions
11076
fcbdee9cdd74 more work
unc0rr
parents: 11075
diff changeset
   179
        realHandlersArray = text "const handlers: array[TCmdType] of PHandler = "
11427
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   180
            <> parens (hsep . punctuate comma . concatMap (map ((<>) (text "PHandler") . parens) . rhentry "@handler_") $ sortedCmdDescriptions) <> semi
11075
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   181
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   182
rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   183
    $+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi
11075
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   184
    , emptyBody] else empty
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   185
    where
842eb00b36ac Generate handlers for lists
unc0rr
parents: 11073
diff changeset
   186
        emptyBody = text "begin"  $+$ text "end" <> semi
10908
1bd7a3a28b18 Try another approach, WIP
unc0rr
parents: 10906
diff changeset
   187
11427
1895a9504a35 - Add the rest of protocol commands
unc0rr
parents: 11425
diff changeset
   188
rhentry prefix cmd@(Command n p) = (text . (++) prefix . fixName . cmdName $ cmd)
11413
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   189
    : if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else []
ffff8a0d1a76 Implement processing net commands in the main thread
unc0rr
parents: 11076
diff changeset
   190
11047
46482475af2b Generate parameters structures
unC0Rr
parents: 10933
diff changeset
   191
pas = renderArrays $ buildTables $ buildParseTree commandsDescription
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   192
    where
10927
336f5ad638be Fix jumpts table, build array of handlers (wip)
unc0rr
parents: 10925
diff changeset
   193
        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
   194
        walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) =
10931
384765cd0caf Parse net commands, answer to pings
unc0rr
parents: 10929
diff changeset
   195
            (lc, 1:sh, pc - 1, "#10":tbl1, show pc:tbl2, (n:t3):tbl3)
10925
be9ce3dc3739 Produce some useful code
unc0rr
parents: 10908
diff changeset
   196
        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
   197
        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
   198
        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
   199
        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
   200
11428
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   201
main = do
cc12bba5b2a2 Support for protocol commands which are equal to suffix of another protocol command
unC0Rr
parents: 11427
diff changeset
   202
    putStrLn $ renderStyle style{mode = ZigZagMode, lineLength = 80} $ pas
11050
9b7c8c5a94e0 Some fixes
unc0rr
parents: 11048
diff changeset
   203
    --putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription