From da0aef961fef08e2690f0dff272b57340dc1d151 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Feb 2016 01:44:35 +0000 Subject: Inverse to bbcode --- tp-bbcode/src/Thermoprint/Printout/BBCode.hs | 3 ++ .../src/Thermoprint/Printout/BBCode/Inverse.hs | 53 ++++++++++++++++++++++ tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs | 27 +++++++++-- tp-bbcode/thermoprint-bbcode.cabal | 2 + tp-bbcode/thermoprint-bbcode.nix | 7 +-- 5 files changed, 84 insertions(+), 8 deletions(-) create mode 100644 tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs 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 -- cgit v1.2.3