tools/protocolParser.hs
branchqmlfrontend
changeset 10904 ce265b038220
parent 10902 29519fe63fdd
child 10906 13fde38281fc
equal deleted inserted replaced
10902:29519fe63fdd 10904:ce265b038220
     1 module Main where
     1 module Main where
     2 
     2 
     3 import Text.PrettyPrint.HughesPJ
     3 import Text.PrettyPrint.HughesPJ
       
     4 import qualified Data.MultiMap as MM
       
     5 import Data.Maybe
       
     6 import Data.List
     4 
     7 
     5 data HWProtocol = Command String [CmdParam]
     8 data HWProtocol = Command String [CmdParam]
     6 data CmdParam = Skip
     9 data CmdParam = Skip
     7               | SS
    10               | SS
     8               | LS
    11               | LS
    26         cmd "CONNECTED" [Skip, IntP]
    29         cmd "CONNECTED" [Skip, IntP]
    27         , cmd1 "NICK" SS
    30         , cmd1 "NICK" SS
    28         , cmd1 "PROTO" IntP
    31         , cmd1 "PROTO" IntP
    29         , cmd1 "ASKPASSWORD" SS
    32         , cmd1 "ASKPASSWORD" SS
    30         , cmd1 "SERVER_AUTH" SS
    33         , cmd1 "SERVER_AUTH" SS
       
    34         , cmd1 "JOINING" SS
       
    35         , cmd1 "BANLIST" $ Many [SS]
       
    36         , cmd1 "JOINED" $ Many [SS]
    31         , cmd1 "LOBBY:JOINED" $ Many [SS]
    37         , cmd1 "LOBBY:JOINED" $ Many [SS]
    32         , cmd2 "LOBBY:LEFT" $ SS SS
    38         , cmd2 "LOBBY:LEFT" SS LS
    33         , cmd2 "CLIENT_FLAGS" $ SS $ Many [SS]
    39         , cmd2 "CLIENT_FLAGS" SS $ Many [SS]
       
    40         , cmd2 "LEFT" SS $ Many [SS]
    34         , cmd1 "SERVER_MESSAGE" LS
    41         , cmd1 "SERVER_MESSAGE" LS
       
    42         , cmd1 "EM" $ Many [LS]
       
    43         , cmd1 "PING" $ Many [SS]
       
    44         , cmd2 "CHAT" SS LS
       
    45         , cmd2 "SERVER_VARS" SS LS
       
    46         , cmd2 "BYE" SS LS
       
    47         , cmd "INFO" [SS, SS, SS, SS]
       
    48         , cmd "KICKED" []
    35     ]
    49     ]
    36 
    50 
       
    51 groupByFirstChar :: [HWProtocol] -> [(Char, [HWProtocol])]
       
    52 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
    37 
    53 
       
    54 buildParseTree cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree
       
    55     where
       
    56         emptyNamed = find (\(_, (Command n _:_)) -> null n) assocs
       
    57         assocs = groupByFirstChar cmds
       
    58         subtree = map (\(c, cmds) -> PTChar c $ buildParseTree cmds) assocs
       
    59         cmdLeaf (c, (hwc:_)) = [PTChar c [PTCommand hwc]]
    38 
    60 
    39 pas = 
    61 dumpTree (PTChar c st) = char c $$ (nest 2 $ vcat $ map dumpTree st)
       
    62 dumpTree _ = empty
       
    63 
       
    64 pas = vcat . map dumpTree $ buildParseTree commands
    40     
    65     
    41 main = putStrLn $ render pas
    66 main = putStrLn $ render pas