-- -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- { module Parser ( parse ) where import Lexer import Syntax import Logging import Array -- parse takes an additional argument saying which state we're in. -- This state flag is use } -- we'll just let any specials/reservedXs die as happyErrors, at the moment %token -- symbols ':' { T _ Colon } '\\' { T _ BackSlash } '/' { T _ FwdSlash } 'nl' { T _ EOL } -- 3.2.2 "Messages". -- Register -- 'reg' { T _ (NameT "reg") } -- World Skeleton 'wsk' { T _ (NameT "wsk") } 'name' { T _ (NameT "name") } 'cop' { T _ (NameT "cop") } 'nod' { T _ (NameT "nod") } 'edg' { T _ (NameT "edg") } -- World 'wor' { T _ (NameT "wor") } 'rbd' { T _ (NameT "rbd") } 'bv' { T _ (NameT "bv") } 'ev' { T _ (NameT "ev") } 'smell' { T _ (NameT "smell") } 'pl' { T _ (NameT "pl") } -- Move -- 'mov' { T _ (NameT "mov") } -- Game Over 'game-over' { T _ (NameT "game-over") } -- Inform 'inf' { T _ (NameT "inf") } -- Suggest Plan 'plan' { T _ (NameT "plan") } -- Voting -- 'vote' { T _ (NameT "vote") } -- Vote Tally 'winner' { T _ (NameT "winner") } 'nowinner' { T _ (NameT "nowinner") } -- From 'from' { T _ (NameT "from") } -- Extensions to the world message 'dc' { T _ (NameT "dc") } -- list of dirty cops 'sc' { T _ (NameT "sc") } -- list of scoundrels 'fac' { T _ (NameT "fac") } -- false accusations -- new game over message 'accused' { T _ (NameT "accused") } -- new offered cops message to robber 'nottelling' { T _ (NameT "nottelling") } 'ofc' { T _ (NameT "ofc") } NAME { T _ (NameT $$) } %name parse %tokentype { Token } %% -- --------------------------------------------------------------------- -- -- All messages we may receive from the server: parse :: { ParserT } : worldskeleton { const $ MsgWorldSkel $1 } | world { const $ MsgWorld $1 } | gameover { const $ MsgGameOver $1 } | accused { const $ MsgAccused $1 } | voteresult { const $ MsgVoteRes $1 } | offeredcops { const $ MsgOfferedCops $1 } | frommsg { \st -> case renameF st $1 of Left i -> MsgFromInf i Right i -> MsgFromPlan i } -- --------------------------------------------------------------------- -- World Skeleton: S -> C -- worldskeleton :: { WorldSkeleton } : 'wsk' '\\' 'nl' 'name' ':' NAME 'nl' NAME{-robber-} ':' NAME 'nl' cops nodeblock edgeblock 'wsk' '/' 'nl' { WorldSkeleton $6 ($10) (reverse $12) ($13) ($14) } ------------------------------------------------------------------------ -- a list of 'cop' descriptors cops :: { Names } : {-epsilon-} { [] } | cops cop { $2 : $1 } cop :: {Name} : 'cop' ':' NAME 'nl' { $3 } ------------------------------------------------------------------------ -- a block of node descriptors -- nodeblock :: { Nodes } : 'nod' '\\' 'nl' nodes 'nod' '/' 'nl' { reverse $4 } nodes :: { Nodes } : {- epsilon -} { [] } | nodes node { $2 : $1 } -- A single node descriptor node :: { Node } : 'nod' ':' NAME NAME NAME NAME 'nl' { Node $3 (mkNodeTag $4) (read $5, read $6) } ------------------------------------------------------------------------ -- a block of edge descriptors -- edgeblock :: { Edges} : 'edg' '\\' 'nl' edges 'edg' '/' 'nl' { reverse $4 } edges :: { Edges } : {- epsilon -} { [] } | edges edge { $2 : $1 } edge :: { Edge } : 'edg' ':' NAME NAME NAME 'nl' { Edge $3 $4 (mkEdgeType $5) } ------------------------------------------------------------------------ -- World : S -> C -- world :: { World } : 'wor' '\\' 'nl' 'wor' ':' NAME 'nl' 'rbd' ':' NAME 'nl' dcblock scblock facblock bvblock evblock 'smell' ':' NAME 'nl' plblock 'wor' '/' 'nl' { World (read $6) (read $10) $12 $13 $14 $15 $16 (if $19 == "0" then Nothing else Just (Smell (read $19))) $21 } ------------------------------------------------------------------------ -- a block of dirty cops -- dcblock :: { Maybe [Name] } : 'dc' '\\' 'nl' dcs 'dc' '/' 'nl' { if null $4 then Nothing else Just $4 } dcs :: { [Name] } : {- epsilon -} { [] } | dcs dc { $2 : $1 } dc :: { Name } : 'dc' ':' NAME 'nl' { $3 } ------------------------------------------------------------------------ -- a block of controlled cops -- scblock :: { [(Name,Name)] } : 'sc' '\\' 'nl' scs 'sc' '/' 'nl' { reverse $4 } scs :: { [(Name,Name)] } : {- epsilon -} { [] } | scs sc { $2 : $1 } sc :: { (Name,Name) } : 'sc' ':' NAME NAME 'nl' { ($3,$4) } ------------------------------------------------------------------------ -- a block of false accusations, over time -- facblock :: { [FAccuse] } : 'fac' '\\' 'nl' facs 'fac' '/' 'nl' { reverse $4 } facs :: { [FAccuse] } : {- epsilon -} { [] } | facs fac { $2 : $1 } fac :: { FAccuse } : 'fac' ':' NAME NAME NAME 'nl' { FAccuse $3 $4 (read $5) } ------------------------------------------------------------------------ -- a block of bank values -- bvblock :: { BankValues } : 'bv' '\\' 'nl' bvs 'bv' '/' 'nl' { reverse $4 } bvs :: { BankValues } : {- epsilon -} { [] } | bvs bv { $2 : $1 } bv :: { BankValue } : 'bv' ':' NAME NAME 'nl' { BankValue $3 (read $4) } ------------------------------------------------------------------------ -- a block of evidence values -- evblock :: { Evidences } : 'ev' '\\' 'nl' evs 'ev' '/' 'nl' { reverse $4 } evs :: { Evidences } : {- epsilon -} { [] } | evs ev { $2 : $1 } ev :: { Evidence } : 'ev' ':' NAME NAME 'nl' { Evidence $3 (read $4) } ------------------------------------------------------------------------ -- a block of players -- plblock :: { Players } : 'pl' '\\' 'nl' pls 'pl' '/' 'nl' { reverse $4 } pls :: { Players } : {- epsilon -} { [] } | pls pl { $2 : $1 } pl :: { Player } : 'pl' ':' NAME NAME NAME 'nl' { Player $3 $4 (mkPType $5) } ------------------------------------------------------------------------ -- The Game Over message gameover :: { GameOver } : 'game-over' 'nl' { GameOver } -- Alternative gameover message for accused cops accused :: { Accused } : 'accused' ':' 'nl' { Accused } ------------------------------------------------------------------------ -- The Vote Tally message voteresult :: { VoteResult } : 'winner' ':' NAME 'nl' { Winner $3 } | 'nowinner' ':' 'nl' { NoWinner } ------------------------------------------------------------------------ -- The Offered Cops Message offeredcops :: { OfferedCops } : 'nottelling' ':' 'nl' { NotTelling } | ofcblock { $1 } ofcblock :: { OfferedCops } : 'ofc' '\\' 'nl' ofcs 'ofc' '/' 'nl' { OfferedCops (reverse $4) } ofcs :: { [Name] } : {- epsilon -} { [] } | ofcs ofc { $2 : $1 } ofc :: { Name } : 'ofc' ':' NAME 'nl' { $3 } ------------------------------------------------------------------------ -- The From Messages frommsg :: { [FromMsg] } : 'from' '\\' 'nl' frommsgs 'from' '/' 'nl' { reverse $4 } frommsgs :: { [FromMsg] } : {- epsilon -} { [] } | frommsgs frommsgbody { $2 : $1 } frommsgbody :: { FromMsg } : 'from' ':' NAME 'nl' msgblock { FromMsg $3 $5 } msgblock :: { FromMsgT } : informmsgblock { FromMsgInf $1 } | planmsgblock { FromMsgPlan $1 } ------------------------------------------------------------------------ -- Inform Message -- informmsgblock :: { Informs } : 'inf' '\\' 'nl' informs 'inf' '/' 'nl' { reverse $4 } informs :: { Informs } : {- epsilon -} { [] } | informs inform { $2 : $1 } inform :: { Inform } : 'inf' ':' NAME NAME NAME NAME NAME 'nl' { Inform $3 $4 (mkPType $5) (read $6) (read $7) } ------------------------------------------------------------------------ -- Plan messages planmsgblock :: { Plans } : 'plan' '\\' 'nl' plans 'plan' '/' 'nl' { reverse $4 } plans :: { Plans } : {- epsilon -} { [] } | plans plan { $2 : $1 } plan :: { Plan } : 'plan' ':' NAME NAME NAME NAME 'nl' { Plan $3 $4 (mkPType $5) (read $6) } { -- -- utilitiies -- ------------------------------------------------------------------------ -- -- We rewrite the flat FromMsgs type into a -- FromMsgsT that distinguishes which form of msg it has properly. -- -- XXX If there aren't any, then we can't distinguish them so assume Inform! -- -- we know what kind of message we required by looking at the tag on the -- head of the list. -- renameF :: ParseStateFlag -> [FromMsg] -> Either FromInform FromPlan renameF InformSt [] = Left $ FromInform [] renameF PlanSt [] = Right $ FromPlan [] renameF DontCareSt [] = niceError "Received 'from' message not in plan or inform state" renameF _st a@((FromMsg _ ty): xs) = case ty of FromMsgInf is -> Left $ FromInform (mkInforms a) FromMsgPlan ps -> Right $ FromPlan (mkPlans a) where mkInforms :: [FromMsg] -> [FromMsgI] mkInforms [] = [] mkInforms ((FromMsg b (FromMsgInf is)):rs) = FromMsgI b is : mkInforms rs mkInforms _ = niceError "found a plan in a list of inform messages!" mkPlans :: [FromMsg] -> [FromMsgP] mkPlans [] = [] mkPlans ((FromMsg b (FromMsgPlan ps)):rs) = FromMsgP b ps : mkPlans rs mkPlans _ = niceError "found an inform in a list of plan messages!" ------------------------------------------------------------------------ -- -- untyped form of from message constructed by parser. -- Lists of these only exist temporarily, and only to disambiguate the grammar. -- They're rewritten by renameF. -- data FromMsg = FromMsg !Name FromMsgT deriving (Show,Eq) data FromMsgT = FromMsgInf !Informs | FromMsgPlan !Plans deriving (Show,Eq) ------------------------------------------------------------------------ -- synonym to hide state argument type ParserT = ParseStateFlag -> RecvMessage ------------------------------------------------------------------------ happyError :: [Token] -> a happyError x = case x of [] -> error $ "DSS-Parser " ++ "parse error at end of file" (T p tk):_ -> error $ "DSS-Parser " ++ showPos p ++ ": " ++ show tk }