blob: 087842f003dbe26cc4310301c96b3792738e5faa (
plain)
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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE OverloadedStrings, OverloadedLists, RankNTypes, ImpredicativeTypes #-}
module BBCode
( parse
, make
) where
import Thermoprint
import BBCode.Tokenizer
import BBCode.Syntax
import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Bifunctor
import Data.List
import Data.Ord
import Data.Foldable
import Data.Function (on)
import Data.CaseInsensitive ( CI )
import qualified Data.CaseInsensitive as CI
import Data.Map ( Map )
import qualified Data.Map as Map
import Prelude hiding (takeWhile)
import Debug.Trace
knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String))
knownTags = [ ("center", Left Center)
, ("u", Right Underline)
]
isBlock, isInline :: String -> Bool
isBlock = testTag isLeft
isInline = testTag isRight
testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags)
data Decorated c = Decorated c [String]
deriving (Show, Eq)
make :: Block String -> String
make (Over blocks) = concat $ map make blocks
make (Center block) = "[center]" ++ make block ++ "[/center]\n"
make (Paragraph inline) = make' inline ++ "\n"
make' :: Inline String -> String
make' (Beside inlines) = concat $ map make' inlines
make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]"
make' (Cooked c) = c
make' (Raw _) = error "Cannot transform block containing raw data to bbcode"
parse :: String -> Either String (Block String)
parse input = massage <$> ((remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics)
massage :: Block String -> Block String
massage (Over [x]) = massage x
massage (Over xs) = Over $ map massage xs
massage (Center x) = Center $ massage x
massage (Paragraph x) = Paragraph $ massage' x
massage' :: Inline String -> Inline String
massage' (Beside [x]) = massage' x
massage' (Beside xs) = Beside $ map massage' xs
massage' (Underline x) = Underline $ massage' x
massage' z = z
blockify :: ContentForest -> [Decorated String]
blockify = map sortDeco . concat . map (blockify' [])
where
blockify' _ Empty = []
blockify' initial (Content str) = [str `Decorated` initial]
blockify' initial (Tagged cs tag) = concat $ map (blockify' $ tag : initial) cs
sortDeco :: Decorated c -> Decorated c
sortDeco (Decorated c tags) = Decorated c $ (nubBy ((==) `on` CI.mk) . sortBy blockiness) tags
blockiness :: String -> String -> Ordering
blockiness a b = comparing isBlock a b <> comparing CI.mk a b -- sort also alphabetically for the benefit of remerge
remerge :: [Decorated String] -> ContentForest
remerge [] = []
remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c]
where
applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco
remerge xs = concat $ map toTree $ groupLasts xs
where
groupLasts = groupBy ((==) `on` (listToMaybe . reverse . (\(Decorated _ ds) -> ds)))
-- toTree :: [Decorated String] -> [ContentTree]
toTree [] = []
toTree (x@(Decorated _ []):xs) = map (Content . (\(Decorated c []) -> c)) (x:xs)
toTree (x@(Decorated _ ds):xs) = [Tagged content tag]
where
tag = last ds
content = concat $ map toTree $ groupLasts $ map stripLast (x:xs)
stripLast (Decorated c ds) = Decorated c (init ds)
unknownTag :: forall a. String -> Either String a
unknownTag tag = Left $ "Unknown tag: " ++ tag
semantics :: ContentForest -> Either String (Block String)
semantics forest = Over <$> mapM semantics' forest
semantics' :: ContentTree -> Either String (Block String)
semantics' Empty = Right $ Over []
semantics' (Content str) = Right $ Paragraph (Cooked str)
semantics' (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
Nothing -> unknownTag tag
Just (Left f) -> Over . map f <$> mapM semantics' cs
Just (Right f) -> Paragraph . Beside . map f<$> mapM iSemantics cs
iSemantics :: ContentTree -> Either String (Inline String)
iSemantics Empty = Right $ Beside []
iSemantics (Content str) = Right $ Cooked str
iSemantics (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
Nothing -> unknownTag tag
Just (Left f) -> error "Known inline tag sorted within block"
Just (Right f) -> Beside . map f <$> mapM iSemantics cs
|