Inverse to bbcode

5 files changed, 84 insertions, 8 deletions

diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs
index ce2aa43..cbe2618 100644
--- a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs
+++ b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs
@@ -8,6 +8,7 @@ module Thermoprint.Printout.BBCode
        , BBCodeError(..)
        , TreeError(..)
        , SemanticError(..)
+       , module Thermoprint.Printout.BBCode.Inverse
        ) where
 
 import Data.Text (Text)
@@ -34,6 +35,8 @@ import Data.List (groupBy)
 import Text.BBCode (DomForest, DomTree(..), TreeError(..))
 import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
 
+import Thermoprint.Printout.BBCode.Inverse
+
 import Thermoprint.Printout
 
 import Thermoprint.Printout.BBCode.Attribute
diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs
new file mode 100644
index 0000000..edd4c5a
--- /dev/null
+++ b/tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Thermoprint.Printout.BBCode.Inverse
+       ( cobbcode
+       , UnicodeException(..)
+       ) where
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq ()
+
+import Data.Text (Text)
+import qualified Data.Text as T (pack, empty, isSuffixOf)
+import qualified Data.Text.Lazy as LT (toStrict)
+
+import Data.ByteString.Lazy as LBS (toStrict)
+
+import Data.Text.Encoding
+import Data.Text.Encoding.Error (UnicodeException(..))
+
+import Data.Foldable (toList)
+import Data.List
+import Data.Monoid
+
+import Thermoprint.Printout
+
+cobbcode :: Printout -> Either UnicodeException Text
+cobbcode (toList -> ps) = mconcat . intersperse "\n\n" <$> mapM handlePar ps
+
+handlePar :: Seq Chunk -> Either UnicodeException Text
+handlePar (toList -> cs) = mconcat <$> mapM handleChunk cs
+
+handleChunk :: Chunk -> Either UnicodeException Text
+handleChunk (Cooked b) = Right $ handleBlock b
+handleChunk (Raw bs) = decodeUtf8' $ LBS.toStrict bs
+
+handleBlock :: Block -> Text
+handleBlock (Line l) = handleLine l
+handleBlock (VSpace i)
+  | i /= 0 = "[vspace=" <> T.pack (show i) <> "/]"
+  | otherwise = ""
+handleBlock (NewlSep (toList -> bs)) = mconcat . intersperse "\n" $ map handleBlock bs
+
+handleLine :: Line -> Text
+handleLine = flip handleLine' T.empty
+  where
+    handleLine' (HSpace i) p
+      | i == 0 = ""
+      | i == 1 = " "
+      | " " `T.isSuffixOf` p = "[hspace=" <> T.pack (show i) <> "/]"
+      | i <= 2 = T.pack $ genericReplicate i ' '
+      | otherwise = " [hspace=" <> T.pack (show $ i - 2) <> "/] "
+    handleLine' (JuxtaPos ls) p = foldl (\p l -> p <> handleLine' l p) "" ls
+    handleLine' (Line -> b) _ = LT.toStrict $ cotext b
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)
diff --git a/tp-bbcode/thermoprint-bbcode.cabal b/tp-bbcode/thermoprint-bbcode.cabal
index 98681ca..3d47691 100644
--- a/tp-bbcode/thermoprint-bbcode.cabal
+++ b/tp-bbcode/thermoprint-bbcode.cabal
@@ -18,6 +18,7 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Thermoprint.Printout.BBCode
+                     , Thermoprint.Printout.BBCode.Inverse
   other-modules:       Thermoprint.Printout.BBCode.Attribute
   extensions:          OverloadedStrings
                      , OverloadedLists
@@ -28,6 +29,7 @@ library
                      , containers -any
                      , text -any
                      , case-insensitive -any
+                     , bytestring >=0.10.6 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/tp-bbcode/thermoprint-bbcode.nix b/tp-bbcode/thermoprint-bbcode.nix
index d0b3d2c..7cec719 100644
--- a/tp-bbcode/thermoprint-bbcode.nix
+++ b/tp-bbcode/thermoprint-bbcode.nix
@@ -1,5 +1,5 @@
-{ mkDerivation, aeson, base, bbcode, case-insensitive, containers
-, hspec, QuickCheck, quickcheck-instances, stdenv, text
+{ mkDerivation, aeson, base, bbcode, bytestring, case-insensitive
+, containers, hspec, QuickCheck, quickcheck-instances, stdenv, text
 , thermoprint-spec
 }:
 mkDerivation {
@@ -7,7 +7,8 @@ mkDerivation {
   version = "1.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    base bbcode case-insensitive containers text thermoprint-spec
+    base bbcode bytestring case-insensitive containers text
+    thermoprint-spec
   ];
   testHaskellDepends = [
     aeson base containers hspec QuickCheck quickcheck-instances text