[Haskell-cafe] Haskell scripting system (please help me simplify the design)

27 Oct 2005

      Folks,

With lots of help from #haskell and haskell-cafe I came up with the  
following setup. It's working fine but requires quite a bit of  
boilerplate code. Could you please help me simplify it?

I apologize for the very long message and will describe any parts  
that are unclear. Please ask away. This is my first Haskell code,  
written over the course of 3 weeks (1 week to learn Haskell) so I'm  
bound to get some things wrong or unoptimal. Still, I'm quite amazed  
that I have been able to get this to work and to work correctly in  
such a short time span.

The system is basically a scripting engine to test a poker server  
that lets you write simple scripts. I went out of my way to enable QA  
techs to use as little Haskell as possible, thus I'm treating all  
poker commands/packets as a list of properties.

What I found is that I'm writing a lot of boiler-plate code to handle  
the convertion of property values into "storables". I think this  
dovetails into the recent GADT discussion. I wonder if my design and  
interaction between Packet, Convertible, Prop and Attr can be  
simplified.

These are a couple of sample scripts (incomplete):

---
module Test where

import Script
import Handshake as H

script env =
     do setDebugLevel 100
        dotimes 1 $ launch $ H.script []
        waitForChildren
---

module Handshake where

import Script

script env =
     -- connect to server
     do world <- connect env "192.168.0.197" 15667
        -- setup callbacks
        world <- add world [
                            [ onCmd := CmdHandshake Server,
                              call := onServerHandshake ],
                            [ onCmd := CmdConnectGame Server,
                              call := onConnectGame ],
                            [ onCmd := CmdServerInfo Server,
                              call := onServerInfo ],
                            [ onCmd := CmdLogon Server,
                              call := onLogon ],
                            [ onCmd := CmdGameInfo Server,
                              call := onGameInfo ],
                            [ onCmd := CmdMoney Server,
                              call := onMoney ]
                           ]
        -- start handshake
        send world $ make (CmdHandshake Invalid) []
        run world

onServerHandshake cmd world =
     do send world $ make (CmdConnectGame Client)
                 [ localIP := "10.0.0.2",
                   affiliateID := [28] ]
        return world

onServerInfo cmd world =
     do send world $ make (CmdLogon Client) [ name := "foo",
                                               password := "bar",
                                               affiliateID := [28] ]
        -- retrieve table id
        tables' <- get tables cmd
        debug 99 $ "Tables: " ++ show tables'
        tableID' <- get tableID $ head tables'
        debug 99 $ "TableID: " ++ show tableID'
        debug 99 $ "World: " ++ show world
        -- save it for later use
        world <- set (tableID := tableID') world
        -- return updated info
        return world

onGameInfo cmd world =
     do debug 99 "Got game!"
        stop world

---

I'm describing binary packets using properties (from WxHaskell) with  
the added twist that when you say attr := value you can specify what  
value will be converted to for storage.

This is how I would use the system...

This describes the properties for the admin message and wait list  
init commands. I would use the properties to serialize the commmands.

cmdProps (CmdAdminMessage Server) = [ title := "",
                                       message := "",
                                       postAction := 0 ]

cmdProps (CmdSrvWaitListInit Server) = [ waitListTables := [] ]

I also have a "dictionary" that describes the attributes such as  
title, message, postAction, etc. I'm allowing deeply nested lists of  
properties.

title :: Attr String WString = makeAttr "title"
message :: Attr String WString = makeAttr "message"
postAction :: Attr Word8 Word8 = makeAttr "postAction"
waitListTables  :: Attr [TableID] (FixedList Word8 (LE TableID)) =
                    makeAttr "waitListTables"

Attr String WString means that a String is accepted on the right-hand  
side and the string will be converted into a wide string for storage.  
Same thing with a list of table ids that is converted into a list of  
little-endian table ids (word32s) prefixed by a Word8 length for  
storage.

The conversion/casting is done with code like this:

class Convertible a b where
     convert_AB :: a -> b
     convert_BA :: b -> a

instance Convertible [Word8] FastString where
     convert_AB a = packWords a
     convert_BA b = unpackWords b

instance Convertible Bool Bool where
     convert_AB a = a
     convert_BA b = b

instance Convertible Bool Word8 where
     convert_AB True = 1
     convert_AB False = 0
     convert_BA 1 = True
     convert_BA 0 = False

instance Convertible String WString where
     convert_AB a = WString $ FS.pack a
     convert_BA (WString b) = FS.unpack b

instance Convertible (String, String) (WString, WString) where
     convert_AB (a1, a2) = (convert_AB a1, convert_AB a2)
     convert_BA (b1, b2) = (convert_BA b1, convert_BA b2)

instance Convertible [String] (FixedList (LE Word32) WString) where
     convert_AB a = FixedList $ map convert_AB a
     convert_BA (FixedList b) = map convert_BA b

My concern is mostly with a lot of similar boilerplate code required  
for casting, specially in very alike cases like the following:

data Pot = Pot [Prop] deriving (Eq, Show, Typeable)
data BaseTableState = BaseTableState [Prop] deriving (Eq, Show,  
Typeable)

instance Packet Pot where
     unstuff xs = case props
                  of Just props -> (Just $ Pot props, xs')
                     Nothing -> (Nothing, xs)
         where (props, xs') = unstuffprops xs potProps <<< this is  
the only difference
     stuff (Pot a) = stuffprops a
     size (Pot a) = sizeprops a

instance Convertible [Prop] Pot where
     convert_AB a = Pot $ mergeprops a potProps
     convert_BA (Pot b) = b

instance Packet BaseTableState where
     unstuff xs = case props
                  of Just props -> (Just $ BaseTableState props, xs')
                     Nothing -> (Nothing, xs)
         where (props, xs') = unstuffprops xs baseTableStateProps
     stuff (BaseTableState a) = stuffprops a
     size (BaseTableState a) = sizeprops a

instance Convertible [Prop] BaseTableState where
     convert_AB a = BaseTableState $ mergeprops a baseTableStateProps
     convert_BA (BaseTableState b) = b

Notice that the differences are only in the list of properties  
required for conversion. I'm wondering if this can be simplified  
somehow.

This is how I describe serialization:

class (Eq a) => Packet a where
     unstuff :: P.FastString -> (Maybe a, P.FastString)
     stuff :: a -> P.FastString
     size :: a -> Int

instance Packet Word8 where
     unstuff xs
             | P.null xs = (Nothing, xs)
             | otherwise = let (ys, zs) = P.splitAt 1 xs
                           in (Just $ concatBits ys, zs)
     stuff a = P.packWords $ unpackBits a
     size a = 1

instance Packet Bool where
     unstuff xs
         | P.null xs = (Nothing, xs)
         | otherwise = (b, xs')
         where (a :: Maybe Word8, xs') = unstuff xs
               b = case a
                   of Just a -> if a == 0
                                then Just False
                                else Just True
                      Nothing -> Nothing
     stuff True = stuff (1 :: Word8)
     stuff False = stuff (0 :: Word8)
     size a = 1

This is the foundation for properties, with the idea taken from  
WxHaskell and the Convertible twist added on top:

infixr 0 :=

data Prop = forall a b. (Eq a, Eq b, Show a, Packet b, Convertible a b)
     => Attr a b := a
        deriving (Typeable)

instance Show Prop where
     show (Attr name _ _ := x) = name ++ " := " ++ show x

instance Eq Prop where
     (Attr name1 (todyn1, fromdyn1) _ := x1) == (Attr name2 (todyn2,  
fromdyn2) _ := x2)
         | name1 == name1 =
             case fromdyn1 $ todyn2 x2
                  of Just x2 -> x2 == x1
                     Nothing -> False
         | otherwise = False

data Attr a b = Attr String
     (a -> Dynamic, Dynamic -> Maybe a)
     (a -> b, b -> a)

instance Show (Attr a b) where
     show (Attr name _ _) = name

makeAttr :: (Typeable a, Convertible a b) => String -> Attr a b
makeAttr name = Attr name
                 (toDyn, fromDynamic)
                 (convert_AB, convert_BA)

setprop :: Prop -> [Prop] -> [Prop]
setprop _ [] = []
setprop (Attr name (todyn, fromdyn) _ := x) props =
     map setprop' props
         where setprop' prop@(attr@(Attr name' (todyn', fromdyn')  
_) := x')
                   | name == name' =
                       case fromdyn' $ todyn x
                            of Just y -> attr := y
                               Nothing -> prop
                   | otherwise = prop

mergeprops :: [Prop] -> [Prop] -> [Prop]
mergeprops [] props = props
mergeprops (x:xs) props =
     mergeprops xs (setprop x props)

get :: Typeable a => Attr a b -> [Prop] -> IO a
get a b = return $ getprop a b

getprop :: Typeable a => Attr a b -> [Prop] -> a
getprop attr props =
     case findprop attr props
          of Just x -> x
             Nothing -> error $ "Could not retrieve "
                        ++ show attr ++ " from " ++ show props

--
http://wagerlabs.com/

[Haskell-cafe] Haskell scripting system (please help me simplify the design)

Joel Reymont