tp-bbcode/src/Thermoprint/Printout/BBCode/Inverse.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

{-# 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 . getParagraphs -> ps) = mconcat . intersperse "\n\n" <$> mapM handlePar ps

handlePar :: Paragraph -> Either UnicodeException Text
handlePar (toList . getChunks -> 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' (Markup ms l) _ = "[markup " <> foldMap markup ms <> "]" <> handleLine' l T.empty <> "[/markup]"
      where
        markup Bold = "bold=true"
        markup Underline = "underline=true"
        markup DoubleHeight = "doubleHeight=true"
        markup DoubleWidth = "doubleWidth=true"
    handleLine' (JuxtaPos ls) p = foldl (\p l -> p <> handleLine' l p) "" ls
    handleLine' (Line -> b) _ = LT.toStrict $ cotext b