haskell: refactoring

2 files changed, 187 insertions, 275 deletions

diff --git a/haskell/src/Data/MessagePack/Parser.hs b/haskell/src/Data/MessagePack/Parser.hs
index d0cd084..312e95f 100644
--- a/haskell/src/Data/MessagePack/Parser.hs
+++ b/haskell/src/Data/MessagePack/Parser.hs
@@ -40,173 +40,133 @@ class ObjectGet a where
   -- | Deserialize a value
   get :: A.Parser a
 
+instance ObjectGet Object where
+  get =
+    A.choice
+    [ liftM ObjectInteger get
+    , liftM (\() -> ObjectNil) get
+    , liftM ObjectBool get
+    , liftM ObjectDouble get
+    , liftM ObjectRAW get
+    , liftM ObjectArray get
+    , liftM ObjectMap get
+    ]
+
 instance ObjectGet Int where
-  get = parseInt
+  get = do
+    c <- A.anyWord8
+    case c of
+      _ | c .&. 0x80 == 0x00 ->
+        return $ fromIntegral c
+      _ | c .&. 0xE0 == 0xE0 ->
+        return $ fromIntegral (fromIntegral c :: Int8)
+      0xCC ->
+        return . fromIntegral =<< A.anyWord8
+      0xCD ->
+        return . fromIntegral =<< parseUint16
+      0xCE ->
+        return . fromIntegral =<< parseUint32
+      0xCF ->
+        return . fromIntegral =<< parseUint64
+      0xD0 ->
+        return . fromIntegral =<< parseInt8
+      0xD1 ->
+        return . fromIntegral =<< parseInt16
+      0xD2 ->
+        return . fromIntegral =<< parseInt32
+      0xD3 ->
+        return . fromIntegral =<< parseInt64
+      _ ->
+        fail $ printf "invlid integer tag: 0x%02X" c
 
 instance ObjectGet () where
-  get = parseNil
+  get = do
+    c <- A.anyWord8
+    case c of
+      0xC0 ->
+        return ()
+      _ ->
+        fail $ printf "invlid nil tag: 0x%02X" c
 
 instance ObjectGet Bool where
-  get = parseBool
+  get = do
+    c <- A.anyWord8
+    case c of
+      0xC3 ->
+        return True
+      0xC2 ->
+        return False
+      _ ->
+        fail $ printf "invlid bool tag: 0x%02X" c
 
 instance ObjectGet Double where
-  get = parseDouble
+  get = do
+    c <- A.anyWord8
+    case c of
+      0xCA ->
+        return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
+      0xCB ->
+        return . runGet getFloat64be . toLBS =<< A.take 8
+      _ ->
+        fail $ printf "invlid double tag: 0x%02X" c
 
 instance ObjectGet B.ByteString where
-  get = parseRAW
+  get = do
+    c <- A.anyWord8
+    case c of
+      _ | c .&. 0xE0 == 0xA0 ->
+        A.take . fromIntegral $ c .&. 0x1F
+      0xDA ->
+        A.take . fromIntegral =<< parseUint16
+      0xDB ->
+        A.take . fromIntegral =<< parseUint32
+      _ ->
+        fail $ printf "invlid raw tag: 0x%02X" c
 
 instance ObjectGet a => ObjectGet [a] where
-  get = parseArray
+  get = parseArray (flip replicateM get)
 
 instance ObjectGet a => ObjectGet (V.Vector a) where
-  get = parseArrayVector
-
-instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
-  get = parseMap
-
-instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
-  get = parseMapVector
-
-instance ObjectGet Object where
-  get = parseObject
+  get = parseArray (flip V.replicateM get)
 
-parseInt :: A.Parser Int
-parseInt = do
-  c <- A.anyWord8
-  case c of
-    _ | c .&. 0x80 == 0x00 ->
-      return $ fromIntegral c
-    _ | c .&. 0xE0 == 0xE0 ->
-      return $ fromIntegral (fromIntegral c :: Int8)      
-    0xCC ->
-      return . fromIntegral =<< A.anyWord8
-    0xCD ->
-      return . fromIntegral =<< parseUint16
-    0xCE ->
-      return . fromIntegral =<< parseUint32
-    0xCF ->
-      return . fromIntegral =<< parseUint64
-    0xD0 ->
-      return . fromIntegral =<< parseInt8
-    0xD1 ->
-      return . fromIntegral =<< parseInt16
-    0xD2 ->
-      return . fromIntegral =<< parseInt32
-    0xD3 ->
-      return . fromIntegral =<< parseInt64
-    _ ->
-      fail $ printf "invlid integer tag: 0x%02X" c
-
-parseNil :: A.Parser ()
-parseNil = do
-  _ <- A.word8 0xC0
-  return ()
-
-parseBool :: A.Parser Bool
-parseBool = do
-  c <- A.anyWord8
-  case c of
-    0xC3 ->
-      return True
-    0xC2 ->
-      return False
-    _ ->
-      fail $ printf "invlid bool tag: 0x%02X" c
-
-parseDouble :: A.Parser Double
-parseDouble = do
-  c <- A.anyWord8
-  case c of
-    0xCA ->
-      return . realToFrac . runGet getFloat32be . toLBS =<< A.take 4
-    0xCB ->
-      return . runGet getFloat64be . toLBS =<< A.take 8
-    _ ->
-      fail $ printf "invlid double tag: 0x%02X" c
-
-parseRAW :: A.Parser B.ByteString
-parseRAW = do
-  c <- A.anyWord8
-  case c of
-    _ | c .&. 0xE0 == 0xA0 ->
-      A.take . fromIntegral $ c .&. 0x1F
-    0xDA ->
-      A.take . fromIntegral =<< parseUint16
-    0xDB ->
-      A.take . fromIntegral =<< parseUint32
-    _ ->
-      fail $ printf "invlid raw tag: 0x%02X" c
-  
-parseArray :: ObjectGet a => A.Parser [a]
-parseArray = do
+parseArray :: (Int -> A.Parser a) -> A.Parser a
+parseArray aget = do
   c <- A.anyWord8
   case c of
     _ | c .&. 0xF0 == 0x90 ->
-      flip replicateM get . fromIntegral $ c .&. 0x0F
+      aget . fromIntegral $ c .&. 0x0F
     0xDC ->
-      flip replicateM get . fromIntegral =<< parseUint16
+      aget . fromIntegral =<< parseUint16
     0xDD ->
-      flip replicateM get . fromIntegral =<< parseUint32
+      aget . fromIntegral =<< parseUint32
     _ ->
       fail $ printf "invlid array tag: 0x%02X" c
 
-parseArrayVector :: ObjectGet a => A.Parser (V.Vector a)
-parseArrayVector = do
-  c <- A.anyWord8
-  case c of
-    _ | c .&. 0xF0 == 0x90 ->
-      flip V.replicateM get . fromIntegral $ c .&. 0x0F
-    0xDC ->
-      flip V.replicateM get . fromIntegral =<< parseUint16
-    0xDD ->
-      flip V.replicateM get . fromIntegral =<< parseUint32
-    _ ->
-      fail $ printf "invlid array tag: 0x%02X" c
+instance (ObjectGet k, ObjectGet v) => ObjectGet [(k, v)] where
+  get = parseMap (flip replicateM parsePair)
 
-parseMap :: (ObjectGet k, ObjectGet v) => A.Parser [(k, v)]
-parseMap = do
-  c <- A.anyWord8
-  case c of
-    _ | c .&. 0xF0 == 0x80 ->
-      flip replicateM parsePair . fromIntegral $ c .&. 0x0F
-    0xDE ->
-      flip replicateM parsePair . fromIntegral =<< parseUint16
-    0xDF ->
-      flip replicateM parsePair . fromIntegral =<< parseUint32
-    _ ->
-      fail $ printf "invlid map tag: 0x%02X" c
+instance (ObjectGet k, ObjectGet v) => ObjectGet (V.Vector (k, v)) where
+  get = parseMap (flip V.replicateM parsePair)
 
-parseMapVector :: (ObjectGet k, ObjectGet v) => A.Parser (V.Vector (k, v))
-parseMapVector = do
+parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
+parsePair = do
+  a <- get
+  b <- get
+  return (a, b)
+
+parseMap :: (Int -> A.Parser a) -> A.Parser a
+parseMap aget = do
   c <- A.anyWord8
   case c of
     _ | c .&. 0xF0 == 0x80 ->
-      flip V.replicateM parsePair . fromIntegral $ c .&. 0x0F
+      aget . fromIntegral $ c .&. 0x0F
     0xDE ->
-      flip V.replicateM parsePair . fromIntegral =<< parseUint16
+      aget . fromIntegral =<< parseUint16
     0xDF ->
-      flip V.replicateM parsePair . fromIntegral =<< parseUint32
+      aget . fromIntegral =<< parseUint32
     _ ->
       fail $ printf "invlid map tag: 0x%02X" c
 
-parseObject :: A.Parser Object
-parseObject =
-  A.choice
-  [ liftM ObjectInteger parseInt
-  , liftM (const ObjectNil) parseNil
-  , liftM ObjectBool parseBool
-  , liftM ObjectDouble parseDouble
-  , liftM ObjectRAW parseRAW
-  , liftM ObjectArray parseArray
-  , liftM ObjectMap parseMap
-  ]
-
-parsePair :: (ObjectGet k, ObjectGet v) => A.Parser (k, v)
-parsePair = do
-  a <- get
-  b <- get
-  return (a, b)
-
 parseUint16 :: A.Parser Word16
 parseUint16 = do
   b0 <- A.anyWord8
diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs
index 8d0af2b..95582dd 100644
--- a/haskell/src/Data/MessagePack/Put.hs
+++ b/haskell/src/Data/MessagePack/Put.hs
@@ -35,168 +35,120 @@ class ObjectPut a where
   put :: a -> Put
 
 instance ObjectPut Object where
-  put = putObject
+  put obj =
+    case obj of
+      ObjectInteger n ->
+        put n
+      ObjectNil ->
+        put ()
+      ObjectBool b ->
+        put b
+      ObjectDouble d ->
+        put d
+      ObjectRAW raw ->
+        put raw
+      ObjectArray arr ->
+        put arr
+      ObjectMap m ->
+        put m
 
 instance ObjectPut Int where
-  put = putInteger
+  put n =
+    case n of
+      _ | n >= 0 && n <= 127 ->
+        putWord8 $ fromIntegral n
+      _ | n >= -32 && n <= -1 ->
+        putWord8 $ fromIntegral n
+      _ | n >= 0 && n < 0x100 -> do
+        putWord8 0xCC
+        putWord8 $ fromIntegral n
+      _ | n >= 0 && n < 0x10000 -> do
+        putWord8 0xCD
+        putWord16be $ fromIntegral n
+      _ | n >= 0 && n < 0x100000000 -> do
+        putWord8 0xCE
+        putWord32be $ fromIntegral n
+      _ | n >= 0 -> do
+        putWord8 0xCF
+        putWord64be $ fromIntegral n
+      _ | n >= -0x80 -> do
+        putWord8 0xD0
+        putWord8 $ fromIntegral n
+      _ | n >= -0x8000 -> do
+        putWord8 0xD1
+        putWord16be $ fromIntegral n
+      _ | n >= -0x80000000 -> do
+        putWord8 0xD2
+        putWord32be $ fromIntegral n
+      _ -> do
+        putWord8 0xD3
+        putWord64be $ fromIntegral n
 
 instance ObjectPut () where
-  put _ = putNil
+  put _ = 
+    putWord8 0xC0
 
 instance ObjectPut Bool where
-  put = putBool
+  put True = putWord8 0xC3
+  put False = putWord8 0xC2
 
 instance ObjectPut Double where
-  put = putDouble
+  put d = do
+    putWord8 0xCB
+    putFloat64be d
 
 instance ObjectPut B.ByteString where
-  put = putRAW
+  put bs = do
+    case len of
+      _ | len <= 31 -> do
+        putWord8 $ 0xA0 .|. fromIntegral len
+      _ | len < 0x10000 -> do
+        putWord8 0xDA
+        putWord16be $ fromIntegral len
+      _ -> do
+        putWord8 0xDB
+        putWord32be $ fromIntegral len
+    putByteString bs
+    where
+      len = B.length bs
 
 instance ObjectPut a => ObjectPut [a] where
-  put = putArray
+  put = putArray length (mapM_ put)
 
 instance ObjectPut a => ObjectPut (V.Vector a) where
-  put = putArrayVector
+  put = putArray V.length (V.mapM_ put)
 
-instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
-  put = putMap
-
-instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
-  put = putMapVector
-
-putObject :: Object -> Put
-putObject obj =
-  case obj of
-    ObjectInteger n ->
-      putInteger n
-    ObjectNil ->
-      putNil
-    ObjectBool b ->
-      putBool b
-    ObjectDouble d ->
-      putDouble d
-    ObjectRAW raw ->
-      putRAW raw
-    ObjectArray arr ->
-      putArray arr
-    ObjectMap m ->
-      putMap m
-
-putInteger :: Int -> Put      
-putInteger n =
-  case n of
-    _ | n >= 0 && n <= 127 ->
-      putWord8 $ fromIntegral n
-    _ | n >= -32 && n <= -1 ->
-      putWord8 $ fromIntegral n
-    _ | n >= 0 && n < 0x100 -> do
-      putWord8 0xCC
-      putWord8 $ fromIntegral n
-    _ | n >= 0 && n < 0x10000 -> do
-      putWord8 0xCD
-      putWord16be $ fromIntegral n
-    _ | n >= 0 && n < 0x100000000 -> do
-      putWord8 0xCE
-      putWord32be $ fromIntegral n
-    _ | n >= 0 -> do
-      putWord8 0xCF
-      putWord64be $ fromIntegral n
-    _ | n >= -0x80 -> do
-      putWord8 0xD0
-      putWord8 $ fromIntegral n
-    _ | n >= -0x8000 -> do
-      putWord8 0xD1
-      putWord16be $ fromIntegral n
-    _ | n >= -0x80000000 -> do
-      putWord8 0xD2
-      putWord32be $ fromIntegral n
-    _ -> do
-      putWord8 0xD3
-      putWord64be $ fromIntegral n
-
-putNil :: Put
-putNil = putWord8 0xC0
-
-putBool :: Bool -> Put
-putBool True = putWord8 0xC3
-putBool False = putWord8 0xC2
-
-putDouble :: Double -> Put
-putDouble d = do
-  putWord8 0xCB
-  putFloat64be d
-
-putRAW :: B.ByteString -> Put
-putRAW bs = do
-  case len of
-    _ | len <= 31 -> do
-      putWord8 $ 0xA0 .|. fromIntegral len
-    _ | len < 0x10000 -> do
-      putWord8 0xDA
-      putWord16be $ fromIntegral len
-    _ -> do
-      putWord8 0xDB
-      putWord32be $ fromIntegral len
-  putByteString bs
-  where
-    len = B.length bs
-
-putArray :: ObjectPut a => [a] -> Put
-putArray arr = do
-  case len of
-    _ | len <= 15 ->
+putArray :: (a -> Int) -> (a -> Put) -> a -> Put
+putArray lf pf arr = do
+  case lf arr of
+    len | len <= 15 ->
       putWord8 $ 0x90 .|. fromIntegral len
-    _ | len < 0x10000 -> do
+    len | len < 0x10000 -> do
       putWord8 0xDC
       putWord16be $ fromIntegral len
-    _ -> do
+    len -> do
       putWord8 0xDD
       putWord32be $ fromIntegral len
-  mapM_ put arr
-  where
-    len = length arr
-
-putArrayVector :: ObjectPut a => V.Vector a -> Put
-putArrayVector arr = do
-  case len of
-    _ | len <= 15 ->
-      putWord8 $ 0x90 .|. fromIntegral len
-    _ | len < 0x10000 -> do
-      putWord8 0xDC
-      putWord16be $ fromIntegral len
-    _ -> do
-      putWord8 0xDD
-      putWord32be $ fromIntegral len
-  V.mapM_ put arr
-  where
-    len = V.length arr
-
-putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
-putMap m = do
-  case len of
-    _ | len <= 15 ->
-      putWord8 $ 0x80 .|. fromIntegral len
-    _ | len < 0x10000 -> do
-      putWord8 0xDE
-      putWord16be $ fromIntegral len
-    _ -> do
-      putWord8 0xDF
-      putWord32be $ fromIntegral len
-  mapM_ (\(k, v) -> put k >> put v) m
-  where
-    len = length m
-
-putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put
-putMapVector m = do
-  case len of
-    _ | len <= 15 ->
+  pf arr
+
+instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
+  put = putMap length (mapM_ putPair)
+
+instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
+  put = putMap V.length (V.mapM_ putPair)
+
+putPair :: (ObjectPut a, ObjectPut b) => (a, b) -> Put
+putPair (a, b) = put a >> put b
+
+putMap :: (a -> Int) -> (a -> Put) -> a -> Put
+putMap lf pf m = do
+  case lf m of
+    len | len <= 15 ->
       putWord8 $ 0x80 .|. fromIntegral len
-    _ | len < 0x10000 -> do
+    len | len < 0x10000 -> do
       putWord8 0xDE
       putWord16be $ fromIntegral len
-    _ -> do
+    len -> do
       putWord8 0xDF
       putWord32be $ fromIntegral len
-  V.mapM_ (\(k, v) -> put k >> put v) m
-  where
-    len = V.length m
+  pf m