diff options
Diffstat (limited to 'bbcode/src/Text/BBCode.hs')
-rw-r--r-- | bbcode/src/Text/BBCode.hs | 31 |
1 files changed, 26 insertions, 5 deletions
diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs index 6fef446..0773124 100644 --- a/bbcode/src/Text/BBCode.hs +++ b/bbcode/src/Text/BBCode.hs | |||
@@ -40,6 +40,7 @@ import Data.Bifunctor (Bifunctor(first)) | |||
40 | 40 | ||
41 | -- | Our target structure -- a rose tree with an explicit terminal constructor | 41 | -- | Our target structure -- a rose tree with an explicit terminal constructor |
42 | data DomTree = Element Text (Map Text Text) [DomTree] | 42 | data DomTree = Element Text (Map Text Text) [DomTree] |
43 | | Paragraph [DomTree] | ||
43 | | Content Text | 44 | | Content Text |
44 | deriving (Show, Eq) | 45 | deriving (Show, Eq) |
45 | 46 | ||
@@ -51,6 +52,7 @@ dom = map dom' | |||
51 | where | 52 | where |
52 | dom' (Node (BBPlain t) _) = Content t | 53 | dom' (Node (BBPlain t) _) = Content t |
53 | dom' (Node (BBTag t attrs) ts) = Element t attrs $ map dom' ts | 54 | dom' (Node (BBTag t attrs) ts) = Element t attrs $ map dom' ts |
55 | dom' (Node BBPar ts) = Paragraph $ map dom' ts | ||
54 | 56 | ||
55 | -- | Errors encountered during parsing | 57 | -- | Errors encountered during parsing |
56 | data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens | 58 | data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens |
@@ -72,6 +74,7 @@ instance Exception TreeError | |||
72 | 74 | ||
73 | -- | The label of our rose-tree nodes carries the tag name and a map of attributes | 75 | -- | The label of our rose-tree nodes carries the tag name and a map of attributes |
74 | data BBLabel = BBTag Text (Map Text Text) | 76 | data BBLabel = BBTag Text (Map Text Text) |
77 | | BBPar | ||
75 | | BBPlain Text | 78 | | BBPlain Text |
76 | deriving (Show, Eq) | 79 | deriving (Show, Eq) |
77 | 80 | ||
@@ -89,15 +92,33 @@ rose :: [BBToken] -> Either TreeError (Forest BBLabel) | |||
89 | -- The use of 'Tree' was still deemed desirable because the morphism to a more sensible structure is straightforward and 'Data.Tree.Zipper' provides all the tools needed to implement 'rose' in a sensible fashion | 92 | -- The use of 'Tree' was still deemed desirable because the morphism to a more sensible structure is straightforward and 'Data.Tree.Zipper' provides all the tools needed to implement 'rose' in a sensible fashion |
90 | rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest []) | 93 | rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest []) |
91 | where | 94 | where |
92 | rose' (BBStr t) = return . Z.nextSpace . Z.insert (Node (BBPlain t) []) | 95 | rose' (BBStr t) = return . Z.nextSpace . Z.insert (Node (BBPlain t) []) |
93 | rose' (BBOpen t attrs) = return . Z.children . Z.insert (Node (BBTag t $ Map.fromList attrs) []) | 96 | rose' BBNewPar = return . parBreak -- for more pointless |
97 | rose' (BBOpen t attrs) = return . Z.children . Z.insert (Node (BBTag t $ Map.fromList attrs) []) | ||
94 | rose' (BBContained t attrs) = return . Z.nextSpace . Z.insert (Node (BBTag t $ Map.fromList attrs) []) | 98 | rose' (BBContained t attrs) = return . Z.nextSpace . Z.insert (Node (BBTag t $ Map.fromList attrs) []) |
95 | rose' (BBClose t) = close t -- for more pointless | 99 | rose' (BBClose t) = close t -- for more pointless |
96 | 100 | ||
97 | close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) | 101 | close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) |
98 | close tag pos = do | 102 | close tag pos = do |
99 | pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos | 103 | pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos >>= traversePars |
100 | let | 104 | let |
101 | pTag = (\(BBTag t _) -> t) $ Z.label pos' | 105 | pTag = (\(BBTag t _) -> t) . Z.label $ pos' |
102 | unless (pTag `matches` tag) . Left $ MismatchedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have | 106 | unless (pTag `matches` tag) . Left $ MismatchedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have |
103 | return $ Z.nextSpace pos' | 107 | return $ Z.nextSpace pos' |
108 | where | ||
109 | traversePars pos | ||
110 | | isPar . Z.tree $ pos = Z.parent pos >>= traversePars | ||
111 | | otherwise = return pos | ||
112 | |||
113 | parBreak :: TreePos Empty BBLabel -> TreePos Empty BBLabel | ||
114 | parBreak z = let siblings = reverse $ Z.before z -- We only move ever move right so Z.after will always be empty | ||
115 | |||
116 | siblingsAsPars | ||
117 | | all isPar siblings = z | ||
118 | | otherwise = case Z.parent z of | ||
119 | Nothing -> Z.fromForest $ [Node BBPar siblings] | ||
120 | Just p -> Z.children . Z.modifyTree (\(Node l _) -> Node l [Node BBPar siblings]) $ p | ||
121 | in Z.children . Z.insert (Node BBPar []) . Z.last $ siblingsAsPars | ||
122 | |||
123 | isPar (Node BBPar _) = True | ||
124 | isPar _ = False | ||