aboutsummaryrefslogtreecommitdiff
path: root/bbcode/src/BBCode/Syntax.hs
diff options
context:
space:
mode:
Diffstat (limited to 'bbcode/src/BBCode/Syntax.hs')
-rw-r--r--bbcode/src/BBCode/Syntax.hs108
1 files changed, 0 insertions, 108 deletions
diff --git a/bbcode/src/BBCode/Syntax.hs b/bbcode/src/BBCode/Syntax.hs
deleted file mode 100644
index a196e05..0000000
--- a/bbcode/src/BBCode/Syntax.hs
+++ /dev/null
@@ -1,108 +0,0 @@
1{-# LANGUAGE RecordWildCards #-}
2
3module BBCode.Syntax
4 ( treeify
5 , ContentForest
6 , ContentTree(..)
7 ) where
8
9import BBCode.Tokenizer (Token(..))
10
11import Data.Foldable
12import Data.Bifunctor
13import Data.Monoid
14
15import Control.Monad.State
16import Control.Monad.Trans
17import Control.Monad
18
19import Data.CaseInsensitive ( CI )
20import qualified Data.CaseInsensitive as CI
21
22import Data.Function (on)
23
24type ContentForest = [ContentTree]
25data ContentTree = Content String
26 | Tagged [ContentTree] String
27 | Empty
28 deriving (Show, Eq)
29
30data Step = Down [ContentTree] [ContentTree] String
31 deriving (Show)
32
33data Zipper = Zipper
34 { hole :: String
35 , prevs :: [ContentTree]
36 , steps :: [Step]
37 }
38 deriving (Show)
39
40type Parser = StateT Zipper (Either String)
41abort :: String -> Parser a
42abort = lift . Left
43
44
45treeify :: [Token] -> Either String ContentForest
46treeify tokenStream = second (postProcess . unZip) $ execStateT (mapM_ incorporate tokenStream) (Zipper "" [] [])
47
48postProcess :: ContentForest -> ContentForest
49postProcess forest = do
50 tree <- forest
51 let
52 tree' = postProcess' tree
53 guard $ tree' /= Empty
54 return tree'
55 where
56 postProcess' :: ContentTree -> ContentTree
57 postProcess' (Content "") = Empty
58 postProcess' (Tagged [] _) = Empty
59 postProcess' (Tagged cs t) = Tagged [c' | c <- cs, let c' = postProcess' c, c' /= Empty ] t
60 postProcess' x = x
61
62unZip :: Zipper -> ContentForest
63unZip Zipper{..} = reverse (apply hole steps : prevs)
64
65apply :: String -> [Step] -> ContentTree
66apply hole steps = hole `apply'` (reverse steps)
67apply' "" [] = Empty
68apply' hole [] = Content hole
69apply' hole (Down pres posts tag:steps) = Tagged (reverse pres ++ [hole `apply` steps] ++ posts) tag
70
71incorporate :: Token -> Parser ()
72incorporate (Text str) = append str
73incorporate (Whitespace str)
74 | delimitsPar str = do
75 currSteps <- gets steps
76 if null currSteps then
77 modify (\Zipper{..} -> Zipper { hole = "", steps = [], prevs = (hole `apply` steps : prevs) })
78 else
79 append str
80 | otherwise = append str
81 where
82 delimitsPar str = (sum . map (const (1 :: Integer)) . filter (== '\n') $ str) >= 1
83incorporate (TagOpen tagName) = modify $ (\z@(Zipper{..}) -> z { steps = (Down [] [] tagName : steps) })
84incorporate (TagClose tagName) = do
85 currSteps <- gets steps
86 case currSteps of
87 [] -> abort $ "Closing unopenend tag: " ++ tagName
88 (Down pres posts tagName':s) -> if ((==) `on` CI.mk) tagName tagName' then
89 goUp
90 else
91 abort $ "Mismatched tags: [" ++ tagName' ++ "]...[/" ++ tagName ++ "]"
92
93append :: String -> Parser ()
94append str = modify (\z@(Zipper{..}) -> z { hole = hole ++ str })
95
96goUp :: Parser ()
97goUp = do
98 (Down pres posts tagName:s) <- gets steps
99 hole <- gets hole
100 let
101 steppedHole = Tagged (reverse pres ++ [Content hole] ++ posts) tagName
102 case s of
103 [] -> modify $ (\z@(Zipper{..}) -> Zipper { hole = "", prevs = steppedHole : prevs, steps = [] })
104 (t:ts) -> do
105 let
106 (Down pres posts tagName) = t
107 t' = Down (steppedHole : pres) posts tagName
108 modify $ (\z -> z { hole = "", steps = (t':ts) })