Inverse to bbcode

1 files changed, 22 insertions, 5 deletions

diff --git a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs
index d2cdeed..09b3147 100644
--- a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs
+++ b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE OverloadedStrings, OverloadedLists #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Thermoprint.Printout.BBCodeSpec (spec) where
 
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck (Property, Discard(..), property)
 import Test.QuickCheck.Instances
 
 import Thermoprint.Printout.BBCode
@@ -15,11 +17,13 @@ import qualified Data.Text.Lazy as TL (pack)
 
 import Data.String (IsString(..))
 
-import Control.Monad (zipWithM_)
+import Control.Monad (zipWithM_, join)
 import Data.Monoid ((<>))
 import Data.Function (on)
+import Data.Bifunctor
 
 import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
 
 instance Eq Block where
   (==) = (==) `on` cotext
@@ -30,10 +34,23 @@ instance IsString Line where
 
 spec :: Spec
 spec = do
-  zipWithM_ example [1..] examples
-    where
-      example n (s, ts) = let str = "Example " <> show n
-                          in specify str $ bbcode s == (pOut <$> ts)
+  describe "example texts for bbcode" $
+    zipWithM_ example [1..] examples
+  describe "cobbcode" $ prop "is inverse to bbcode" bbcodeInv
+  where
+    example n (s, ts) = let str = show s
+                        in specify str $ bbcode s == (pOut <$> ts)
+
+bbcodeInv :: Printout -> Property
+bbcodeInv (cobbcode -> Left _) = property True
+bbcodeInv p@(cobbcode -> Right t) = either (const $ property True) property $ (==) <$> normalize (Right p)  <*> normalize (bbcode t)
+  
+normalize = (!! 3) . iterate normalize' . first (const ())
+  where
+    normalize' t = join' (bbcode <$> (join' $ cobbcode <$> t))
+    join' :: Either a (Either b c) -> Either () c
+    join' (Right (Right a)) = Right a
+    join' _ = Left ()
 
 pOut :: Seq Block -> Printout
 pOut = fmap (pure . Cooked)