diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-12 06:12:17 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-01-12 06:12:17 +0000 |
commit | 69fc73e75a7f7fe388023d16990e9e701b7384e0 (patch) | |
tree | fe8abf05e2d49f39a97b32c4dbf4ebe0e00a83e3 /bbcode | |
parent | 934558d25aa1074483ef722236e1e680abf13ebf (diff) | |
download | thermoprint-69fc73e75a7f7fe388023d16990e9e701b7384e0.tar thermoprint-69fc73e75a7f7fe388023d16990e9e701b7384e0.tar.gz thermoprint-69fc73e75a7f7fe388023d16990e9e701b7384e0.tar.bz2 thermoprint-69fc73e75a7f7fe388023d16990e9e701b7384e0.tar.xz thermoprint-69fc73e75a7f7fe388023d16990e9e701b7384e0.zip |
documentation & cleanup
Diffstat (limited to 'bbcode')
-rw-r--r-- | bbcode/src/Text/BBCode.hs | 15 |
1 files changed, 9 insertions, 6 deletions
diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs index 3828c22..4b2ee6e 100644 --- a/bbcode/src/Text/BBCode.hs +++ b/bbcode/src/Text/BBCode.hs | |||
@@ -1,6 +1,7 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | 1 | {-# LANGUAGE OverloadedStrings #-} |
2 | {-# LANGUAGE DeriveGeneric #-} | 2 | {-# LANGUAGE DeriveGeneric #-} |
3 | 3 | ||
4 | -- | An implementation of BBcode parsing 'Text' to a syntax tree (@'Forest' 'BBLabel'@) | ||
4 | module Text.BBCode | 5 | module Text.BBCode |
5 | ( TreeError(..) | 6 | ( TreeError(..) |
6 | , BBLabel | 7 | , BBLabel |
@@ -29,18 +30,20 @@ import qualified Data.Map as Map | |||
29 | import Data.CaseInsensitive (CI) | 30 | import Data.CaseInsensitive (CI) |
30 | import qualified Data.CaseInsensitive as CI | 31 | import qualified Data.CaseInsensitive as CI |
31 | 32 | ||
32 | data TreeError = ImbalancedTags Text Text | 33 | -- | Errors in input encountered during parsing of lexed token-stream |
33 | | LeftoverClose Text | 34 | data TreeError = MismatchedTags Text Text -- ^ Closing tags does not match opening tags |
35 | | ImbalancedTags Text -- ^ We found an extraneous closing tag | ||
34 | deriving (Show, Eq, Generic, Typeable) | 36 | deriving (Show, Eq, Generic, Typeable) |
35 | 37 | ||
36 | instance Exception TreeError | 38 | instance Exception TreeError |
37 | 39 | ||
40 | -- | The label of our rose-tree nodes carries the tag name and a map of attributes | ||
38 | type BBLabel = (Text, Map Text (Maybe Text)) | 41 | type BBLabel = (Text, Map Text (Maybe Text)) |
39 | 42 | ||
40 | matches :: Text -> Text -> Bool | 43 | matches :: Text -> Text -> Bool |
41 | -- ^ @`matches` "open" "close"@ should be true iff @[/close]@ is a valid closing tag for @[open]@ | 44 | -- ^ @`matches` "open" "close"@ should be 'True' iff @[/close]@ is a valid closing tag for @[open]@ |
42 | -- | 45 | -- |
43 | -- > (==) `on` CI.mk | 46 | -- @ (==) `on` 'CI.mk' @ |
44 | matches = (==) `on` CI.mk | 47 | matches = (==) `on` CI.mk |
45 | 48 | ||
46 | rose :: [BBToken] -> Either TreeError (Forest BBLabel) | 49 | rose :: [BBToken] -> Either TreeError (Forest BBLabel) |
@@ -57,8 +60,8 @@ rose = fmap Z.toForest . flip rose' (Z.fromForest []) | |||
57 | 60 | ||
58 | close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) | 61 | close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) |
59 | close tag pos = do | 62 | close tag pos = do |
60 | pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos | 63 | pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos |
61 | let | 64 | let |
62 | pTag = fst $ Z.label pos' | 65 | 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 | 66 | 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 |
64 | return $ Z.nextSpace pos' | 67 | return $ Z.nextSpace pos' |