blob: a6de7b49500cd565afcc2fd5dc872e278500d6c4 (
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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Text.BBCode
( TreeError(..)
, rose
, matches
) where
import Data.Text (Text)
import GHC.Generics (Generic)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Control.Monad (unless)
import Text.BBCode.Lexer (BBToken(..), token)
import Data.Tree
import Data.Tree.Zipper (TreePos, Empty, Full)
import qualified Data.Tree.Zipper as Z
data TreeError = ImbalancedTags Text Text
| LeftoverClose Text
deriving (Show, Eq, Generic, Typeable)
instance Exception TreeError
matches :: Text -> Text -> Bool
-- ^ @`matches` "open" "close"@ should be true iff @[/close]@ is a valid closing tag for @[open]@
--
-- Until we allow for attributes this is equality according to `(==)`
matches = (==)
rose :: [BBToken] -> Either TreeError (Forest Text)
-- ^ 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 Text -> Either TreeError (TreePos Empty Text)
rose' [] = return
rose' (x:xs) = (>>= rose' xs) . rose'' x
rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node t [])
rose'' (BBOpen t _) = return . Z.children . Z.insert (Node t [])
rose'' (BBClose t) = close t -- for more pointless
close :: Text -> TreePos Empty Text -> Either TreeError (TreePos Empty Text)
close tag pos = do
pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos
unless (Z.label pos' `matches` tag) . Left $ ImbalancedTags (Z.label pos') tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
return $ Z.nextSpace pos'
|
