diff --git a/src/Quasar/Wayland/Protocol/Core.hs b/src/Quasar/Wayland/Protocol/Core.hs index 762b5f193b77587dcd3e976df1a99e183156f041..e983781add53f78a2f1b1a3d06f9149a33ddf4ed 100644 --- a/src/Quasar/Wayland/Protocol/Core.hs +++ b/src/Quasar/Wayland/Protocol/Core.hs @@ -32,6 +32,7 @@ module Quasar.Wayland.Protocol.Core ( -- * Message decoder operations WireFormat(..), dropRemaining, + invalidOpcode, ) where import Control.Monad (replicateM_) diff --git a/src/Quasar/Wayland/Protocol/TH.hs b/src/Quasar/Wayland/Protocol/TH.hs index 92393eafab8477ee14c4d0b1a41f241c05c331cd..dab855ad3539063629ed11c35ab287a22a066bb8 100644 --- a/src/Quasar/Wayland/Protocol/TH.hs +++ b/src/Quasar/Wayland/Protocol/TH.hs @@ -224,16 +224,23 @@ isMessageInstanceD :: Q Type -> [MessageContext] -> Q Dec isMessageInstanceD t msgs = instanceD (pure []) [t|IsMessage $t|] [opcodeNameD, getMessageD, putMessageD] where opcodeNameD :: Q Dec - opcodeNameD = funD 'opcodeName (opcodeNameClauseD <$> msgs) - opcodeNameClauseD :: MessageContext -> Q Clause - opcodeNameClauseD msg = clause [litP (integerL (fromIntegral msg.msgSpec.opcode))] (normalB ([|Just $(stringE msg.msgSpec.name)|])) [] + opcodeNameD = funD 'opcodeName ((opcodeNameClause <$> msgs) <> [opcodeNameInvalidClause]) + opcodeNameClause :: MessageContext -> Q Clause + opcodeNameClause msg = clause [litP (integerL (fromIntegral msg.msgSpec.opcode))] (normalB ([|Just $(stringE msg.msgSpec.name)|])) [] + opcodeNameInvalidClause :: Q Clause + opcodeNameInvalidClause = clause [wildP] (normalB ([|Nothing|])) [] getMessageD :: Q Dec - getMessageD = funD 'getMessage (getMessageClauseD <$> msgs) - getMessageClauseD :: MessageContext -> Q Clause - getMessageClauseD msg = clause [wildP, litP (integerL (fromIntegral msg.msgSpec.opcode))] (normalB getMessageE) [] + getMessageD = funD 'getMessage ((getMessageClause <$> msgs) <> [getMessageInvalidOpcodeClause]) + getMessageClause :: MessageContext -> Q Clause + getMessageClause msg = clause [wildP, litP (integerL (fromIntegral msg.msgSpec.opcode))] (normalB getMessageE) [] where getMessageE :: Q Exp getMessageE = applyA (conE (msg.msgConName)) ((\argT -> [|getArgument @($argT)|]) . argumentSpecType <$> msg.msgSpec.arguments) + getMessageInvalidOpcodeClause :: Q Clause + getMessageInvalidOpcodeClause = do + let object = mkName "object" + let opcode = mkName "opcode" + clause [varP object, varP opcode] (normalB [|invalidOpcode $(varE object) $(varE opcode)|]) [] putMessageD :: Q Dec putMessageD = funD 'putMessage (putMessageClauseD <$> msgs) putMessageClauseD :: MessageContext -> Q Clause