aboutsummaryrefslogtreecommitdiff
path: root/bbcode
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2016-01-12 06:12:17 +0000
committerGregor Kleen <gkleen@yggdrasil.li>2016-01-12 06:12:17 +0000
commit69fc73e75a7f7fe388023d16990e9e701b7384e0 (patch)
treefe8abf05e2d49f39a97b32c4dbf4ebe0e00a83e3 /bbcode
parent934558d25aa1074483ef722236e1e680abf13ebf (diff)
downloadthermoprint-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.hs15
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'@)
4module Text.BBCode 5module Text.BBCode
5 ( TreeError(..) 6 ( TreeError(..)
6 , BBLabel 7 , BBLabel
@@ -29,18 +30,20 @@ import qualified Data.Map as Map
29import Data.CaseInsensitive (CI) 30import Data.CaseInsensitive (CI)
30import qualified Data.CaseInsensitive as CI 31import qualified Data.CaseInsensitive as CI
31 32
32data TreeError = ImbalancedTags Text Text 33-- | Errors in input encountered during parsing of lexed token-stream
33 | LeftoverClose Text 34data 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
36instance Exception TreeError 38instance Exception TreeError
37 39
40-- | The label of our rose-tree nodes carries the tag name and a map of attributes
38type BBLabel = (Text, Map Text (Maybe Text)) 41type BBLabel = (Text, Map Text (Maybe Text))
39 42
40matches :: Text -> Text -> Bool 43matches :: 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' @
44matches = (==) `on` CI.mk 47matches = (==) `on` CI.mk
45 48
46rose :: [BBToken] -> Either TreeError (Forest BBLabel) 49rose :: [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'