find and correct single bit errors in 16-bit hamming codes

src/Hamming.hs

@@ -26,7 +26,15 @@ License along with this program.  If not, see
 
 module Hamming (Hamming (..)) where
 
-import Data.Bits (Bits, complement, shiftR, (.&.), (.|.))
+import Data.Bits
+  ( Bits
+  , complement
+  , shiftL
+  , shiftR
+  , xor
+  , (.&.)
+  , (.|.)
+  )
 import Data.Word (Word16)
 
 -- | An implementation of a Hamming code
@@ -55,7 +63,19 @@ instance Hamming Word16 where
     , 0xffff
     ]
 
-  correctErrors = undefined
+  correctErrors c
+    | isValid c = Just c
+    | otherwise = let
+      errorFlags = map (oddParity . (c .&.))
+        [0xaaaa, 0xcccc, 0xf0f0, 0xff00]
+      flipAddr = foldl
+        ( \a (mask, err) -> if err
+          then let
+            in a .|. mask
+          else a
+        ) 0 $ zip [1, 2, 4, 8] errorFlags
+      flipBit = 1 `shiftL` flipAddr
+      in Just $ c `xor` flipBit
 
 setCheckBit :: (Num a, Bits a) => a -> (a, a) -> a
 setCheckBit a (pBit, chkMask) =

test/Hamming/Word16Spec.hs

@@ -21,6 +21,7 @@ License along with this program.  If not, see
 
 module Hamming.Word16Spec (spec) where
 
+import Data.Bits (shiftL, xor)
 import Data.Word (Word16)
 
 import Hamming
@@ -61,8 +62,21 @@ isValidSpec = describe "isValid" $ mapM_
   ]
 
 correctErrorsSpec :: Spec
-correctErrorsSpec = describe "correctErrors" $
+correctErrorsSpec = describe "correctErrors" $ mapM_
-  return ()
+  ( \(desc, code, expected) -> context desc $ let
+    actual = correctErrors code
+    in it ("should be " ++ show expected) $
+      actual `shouldBe` expected
+  ) $ ("valid", withChkBits, Just withChkBits) :
+  singleBitErrors
+
+singleBitErrors :: [(String, Word16, Maybe Word16)]
+singleBitErrors = map
+  ( \bit -> let
+    mask = 1 `shiftL` bit
+    code = withChkBits `xor` mask
+    in ("bad bit " ++ show bit, code, Just withChkBits)
+  ) [0..15]
 
 noChkBits :: Word16
 noChkBits = 0x34c0