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
|
{-# LANGUAGE RecordWildCards #-}
module BBCode.Syntax
( treeify
, ContentForest
, ContentTree(..)
) where
import BBCode.Tokenizer (Token(..))
import Data.Foldable
import Data.Bifunctor
import Data.Monoid
import Control.Monad.State
import Control.Monad.Trans
import Control.Monad
import Data.CaseInsensitive ( CI )
import qualified Data.CaseInsensitive as CI
import Data.Function (on)
type ContentForest = [ContentTree]
data ContentTree = Content String
| Tagged [ContentTree] String
| Empty
deriving (Show, Eq)
data Step = Down [ContentTree] [ContentTree] String
deriving (Show)
data Zipper = Zipper
{ hole :: String
, prevs :: [ContentTree]
, steps :: [Step]
}
deriving (Show)
type Parser = StateT Zipper (Either String)
abort :: String -> Parser a
abort = lift . Left
treeify :: [Token] -> Either String ContentForest
treeify tokenStream = second (postProcess . unZip) $ execStateT (mapM_ incorporate tokenStream) (Zipper "" [] [])
postProcess :: ContentForest -> ContentForest
postProcess forest = do
tree <- forest
let
tree' = postProcess' tree
guard $ tree' /= Empty
return tree'
where
postProcess' :: ContentTree -> ContentTree
postProcess' (Content "") = Empty
postProcess' (Tagged [] _) = Empty
postProcess' (Tagged cs t) = Tagged [c' | c <- cs, let c' = postProcess' c, c' /= Empty ] t
postProcess' x = x
unZip :: Zipper -> ContentForest
unZip Zipper{..} = reverse (apply hole steps : prevs)
apply :: String -> [Step] -> ContentTree
apply hole steps = hole `apply'` (reverse steps)
apply' "" [] = Empty
apply' hole [] = Content hole
apply' hole (Down pres posts tag:steps) = Tagged (reverse pres ++ [hole `apply` steps] ++ posts) tag
incorporate :: Token -> Parser ()
incorporate (Text str) = append str
incorporate (Whitespace str)
| delimitsPar str = do
currSteps <- gets steps
if null currSteps then
modify (\Zipper{..} -> Zipper { hole = "", steps = [], prevs = (hole `apply` steps : prevs) })
else
append str
| otherwise = append str
where
delimitsPar str = (sum . map (const (1 :: Integer)) . filter (== '\n') $ str) >= 1
incorporate (TagOpen tagName) = modify $ (\z@(Zipper{..}) -> z { steps = (Down [] [] tagName : steps) })
incorporate (TagClose tagName) = do
currSteps <- gets steps
case currSteps of
[] -> abort $ "Closing unopenend tag: " ++ tagName
(Down pres posts tagName':s) -> if ((==) `on` CI.mk) tagName tagName' then
goUp
else
abort $ "Mismatched tags: [" ++ tagName' ++ "]...[/" ++ tagName ++ "]"
append :: String -> Parser ()
append str = modify (\z@(Zipper{..}) -> z { hole = hole ++ str })
goUp :: Parser ()
goUp = do
(Down pres posts tagName:s) <- gets steps
hole <- gets hole
let
steppedHole = Tagged (reverse pres ++ [Content hole] ++ posts) tagName
case s of
[] -> modify $ (\z@(Zipper{..}) -> Zipper { hole = "", prevs = steppedHole : prevs, steps = [] })
(t:ts) -> do
let
(Down pres posts tagName) = t
t' = Down (steppedHole : pres) posts tagName
modify $ (\z -> z { hole = "", steps = (t':ts) })
|
