blob: 1e9960a213af854ccb9570e3bea88407a8cb33b9 (
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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
-- | An implementation of BBcode parsing 'Text' to a syntax tree (@'Forest' 'BBLabel'@)
module Text.BBCode
( TreeError(..)
, BBLabel
, rose
, matches
) where
import Data.Text (Text)
import GHC.Generics (Generic)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Control.Monad (unless)
import Data.Function (on)
import Text.BBCode.Lexer (BBToken(..), token)
import Data.Tree
import Data.Tree.Zipper (TreePos, Empty, Full)
import qualified Data.Tree.Zipper as Z
import Data.Map (Map)
import qualified Data.Map as Map
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-- | Errors in input encountered during parsing of lexed token-stream
data TreeError = MismatchedTags Text Text -- ^ Closing tags does not match opening tags
| ImbalancedTags Text -- ^ We found an extraneous closing tag
deriving (Show, Eq, Generic, Typeable)
instance Exception TreeError
-- | The label of our rose-tree nodes carries the tag name and a map of attributes
type BBLabel = (Text, Maybe (Map Text (Maybe Text)))
matches :: Text -> Text -> Bool
-- ^ @`matches` "open" "close"@ should be 'True' iff @[/close]@ is a valid closing tag for @[open]@
--
-- @ (==) `on` 'CI.mk' @
matches = (==) `on` CI.mk
rose :: [BBToken] -> Either TreeError (Forest BBLabel)
-- ^ Assuming that both tags and content have the same type (we use 'Text') bbcode is a flat representation of a rose tree
rose = fmap Z.toForest . flip rose' (Z.fromForest [])
where
rose' :: [BBToken] -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
rose' [] = return
rose' (x:xs) = (>>= rose' xs) . rose'' x
rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node (t, Nothing) [])
rose'' (BBOpen t attrs) = return . Z.children . Z.insert (Node (t, Just $ Map.fromList attrs) [])
rose'' (BBClose t) = close t -- for more pointless
close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
close tag pos = do
pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos
let
pTag = fst $ Z.label pos'
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
return $ Z.nextSpace pos'
|
