Inverse to bbcode

1 files changed, 53 insertions, 0 deletions

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