diff options
Diffstat (limited to 'bbcode/src/Text/BBCode.hs')
-rw-r--r-- | bbcode/src/Text/BBCode.hs | 28 |
1 files changed, 20 insertions, 8 deletions
diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs index a6de7b4..3828c22 100644 --- a/bbcode/src/Text/BBCode.hs +++ b/bbcode/src/Text/BBCode.hs | |||
@@ -3,6 +3,7 @@ | |||
3 | 3 | ||
4 | module Text.BBCode | 4 | module Text.BBCode |
5 | ( TreeError(..) | 5 | ( TreeError(..) |
6 | , BBLabel | ||
6 | , rose | 7 | , rose |
7 | , matches | 8 | , matches |
8 | ) where | 9 | ) where |
@@ -14,6 +15,7 @@ import Control.Exception (Exception) | |||
14 | import Data.Typeable (Typeable) | 15 | import Data.Typeable (Typeable) |
15 | 16 | ||
16 | import Control.Monad (unless) | 17 | import Control.Monad (unless) |
18 | import Data.Function (on) | ||
17 | 19 | ||
18 | import Text.BBCode.Lexer (BBToken(..), token) | 20 | import Text.BBCode.Lexer (BBToken(..), token) |
19 | 21 | ||
@@ -21,32 +23,42 @@ import Data.Tree | |||
21 | import Data.Tree.Zipper (TreePos, Empty, Full) | 23 | import Data.Tree.Zipper (TreePos, Empty, Full) |
22 | import qualified Data.Tree.Zipper as Z | 24 | import qualified Data.Tree.Zipper as Z |
23 | 25 | ||
26 | import Data.Map (Map) | ||
27 | import qualified Data.Map as Map | ||
28 | |||
29 | import Data.CaseInsensitive (CI) | ||
30 | import qualified Data.CaseInsensitive as CI | ||
31 | |||
24 | data TreeError = ImbalancedTags Text Text | 32 | data TreeError = ImbalancedTags Text Text |
25 | | LeftoverClose Text | 33 | | LeftoverClose Text |
26 | deriving (Show, Eq, Generic, Typeable) | 34 | deriving (Show, Eq, Generic, Typeable) |
27 | 35 | ||
28 | instance Exception TreeError | 36 | instance Exception TreeError |
29 | 37 | ||
38 | type BBLabel = (Text, Map Text (Maybe Text)) | ||
39 | |||
30 | matches :: Text -> Text -> Bool | 40 | matches :: Text -> Text -> Bool |
31 | -- ^ @`matches` "open" "close"@ should be true iff @[/close]@ is a valid closing tag for @[open]@ | 41 | -- ^ @`matches` "open" "close"@ should be true iff @[/close]@ is a valid closing tag for @[open]@ |
32 | -- | 42 | -- |
33 | -- Until we allow for attributes this is equality according to `(==)` | 43 | -- > (==) `on` CI.mk |
34 | matches = (==) | 44 | matches = (==) `on` CI.mk |
35 | 45 | ||
36 | rose :: [BBToken] -> Either TreeError (Forest Text) | 46 | rose :: [BBToken] -> Either TreeError (Forest BBLabel) |
37 | -- ^ Assuming that both tags and content have the same type (we use 'Text') bbcode is a flat representation of a rose tree | 47 | -- ^ Assuming that both tags and content have the same type (we use 'Text') bbcode is a flat representation of a rose tree |
38 | rose = fmap Z.toForest . flip rose' (Z.fromForest []) | 48 | rose = fmap Z.toForest . flip rose' (Z.fromForest []) |
39 | where | 49 | where |
40 | rose' :: [BBToken] -> TreePos Empty Text -> Either TreeError (TreePos Empty Text) | 50 | rose' :: [BBToken] -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) |
41 | rose' [] = return | 51 | rose' [] = return |
42 | rose' (x:xs) = (>>= rose' xs) . rose'' x | 52 | rose' (x:xs) = (>>= rose' xs) . rose'' x |
43 | 53 | ||
44 | rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node t []) | 54 | rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node (t, Map.empty) []) |
45 | rose'' (BBOpen t _) = return . Z.children . Z.insert (Node t []) | 55 | rose'' (BBOpen t attrs) = return . Z.children . Z.insert (Node (t, Map.fromList attrs) []) |
46 | rose'' (BBClose t) = close t -- for more pointless | 56 | rose'' (BBClose t) = close t -- for more pointless |
47 | 57 | ||
48 | close :: Text -> TreePos Empty Text -> Either TreeError (TreePos Empty Text) | 58 | close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) |
49 | close tag pos = do | 59 | close tag pos = do |
50 | pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos | 60 | pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos |
51 | 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 | 61 | let |
62 | pTag = fst $ Z.label pos' | ||
63 | 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 | ||
52 | return $ Z.nextSpace pos' | 64 | return $ Z.nextSpace pos' |