blob: 3828c22db9b42761c0cd572960d7fa2323a83d36 (
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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
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
data TreeError = ImbalancedTags Text Text
| LeftoverClose Text
deriving (Show, Eq, Generic, Typeable)
instance Exception TreeError
type BBLabel = (Text, 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, Map.empty) [])
rose'' (BBOpen t attrs) = return . Z.children . Z.insert (Node (t, 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 $ LeftoverClose tag) Right $ Z.parent pos
let
pTag = fst $ Z.label pos'
unless (pTag `matches` tag) . Left $ ImbalancedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
return $ Z.nextSpace pos'
|
