aboutsummaryrefslogtreecommitdiff
path: root/bbcode/src
diff options
context:
space:
mode:
Diffstat (limited to 'bbcode/src')
-rw-r--r--bbcode/src/BBCode.hs120
-rw-r--r--bbcode/src/BBCode/Syntax.hs108
-rw-r--r--bbcode/src/BBCode/Tokenizer.hs44
3 files changed, 0 insertions, 272 deletions
diff --git a/bbcode/src/BBCode.hs b/bbcode/src/BBCode.hs
deleted file mode 100644
index 087842f..0000000
--- a/bbcode/src/BBCode.hs
+++ /dev/null
@@ -1,120 +0,0 @@
1{-# LANGUAGE OverloadedStrings, OverloadedLists, RankNTypes, ImpredicativeTypes #-}
2
3module BBCode
4 ( parse
5 , make
6 ) where
7
8import Thermoprint
9
10import BBCode.Tokenizer
11import BBCode.Syntax
12
13import Data.Maybe
14import Data.Monoid
15import Data.Either
16import Data.Bifunctor
17import Data.List
18import Data.Ord
19import Data.Foldable
20
21import Data.Function (on)
22
23import Data.CaseInsensitive ( CI )
24import qualified Data.CaseInsensitive as CI
25
26import Data.Map ( Map )
27import qualified Data.Map as Map
28
29import Prelude hiding (takeWhile)
30
31import Debug.Trace
32
33knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String))
34knownTags = [ ("center", Left Center)
35 , ("u", Right Underline)
36 ]
37
38isBlock, isInline :: String -> Bool
39isBlock = testTag isLeft
40isInline = testTag isRight
41testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags)
42
43data Decorated c = Decorated c [String]
44 deriving (Show, Eq)
45
46make :: Block String -> String
47make (Over blocks) = concat $ map make blocks
48make (Center block) = "[center]" ++ make block ++ "[/center]\n"
49make (Paragraph inline) = make' inline ++ "\n"
50
51make' :: Inline String -> String
52make' (Beside inlines) = concat $ map make' inlines
53make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]"
54make' (Cooked c) = c
55make' (Raw _) = error "Cannot transform block containing raw data to bbcode"
56
57parse :: String -> Either String (Block String)
58parse input = massage <$> ((remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics)
59
60massage :: Block String -> Block String
61massage (Over [x]) = massage x
62massage (Over xs) = Over $ map massage xs
63massage (Center x) = Center $ massage x
64massage (Paragraph x) = Paragraph $ massage' x
65
66massage' :: Inline String -> Inline String
67massage' (Beside [x]) = massage' x
68massage' (Beside xs) = Beside $ map massage' xs
69massage' (Underline x) = Underline $ massage' x
70massage' z = z
71
72blockify :: ContentForest -> [Decorated String]
73blockify = map sortDeco . concat . map (blockify' [])
74 where
75 blockify' _ Empty = []
76 blockify' initial (Content str) = [str `Decorated` initial]
77 blockify' initial (Tagged cs tag) = concat $ map (blockify' $ tag : initial) cs
78 sortDeco :: Decorated c -> Decorated c
79 sortDeco (Decorated c tags) = Decorated c $ (nubBy ((==) `on` CI.mk) . sortBy blockiness) tags
80 blockiness :: String -> String -> Ordering
81 blockiness a b = comparing isBlock a b <> comparing CI.mk a b -- sort also alphabetically for the benefit of remerge
82
83remerge :: [Decorated String] -> ContentForest
84remerge [] = []
85remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c]
86 where
87 applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco
88remerge xs = concat $ map toTree $ groupLasts xs
89 where
90 groupLasts = groupBy ((==) `on` (listToMaybe . reverse . (\(Decorated _ ds) -> ds)))
91 -- toTree :: [Decorated String] -> [ContentTree]
92 toTree [] = []
93 toTree (x@(Decorated _ []):xs) = map (Content . (\(Decorated c []) -> c)) (x:xs)
94 toTree (x@(Decorated _ ds):xs) = [Tagged content tag]
95 where
96 tag = last ds
97 content = concat $ map toTree $ groupLasts $ map stripLast (x:xs)
98 stripLast (Decorated c ds) = Decorated c (init ds)
99
100unknownTag :: forall a. String -> Either String a
101unknownTag tag = Left $ "Unknown tag: " ++ tag
102
103semantics :: ContentForest -> Either String (Block String)
104semantics forest = Over <$> mapM semantics' forest
105
106semantics' :: ContentTree -> Either String (Block String)
107semantics' Empty = Right $ Over []
108semantics' (Content str) = Right $ Paragraph (Cooked str)
109semantics' (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
110 Nothing -> unknownTag tag
111 Just (Left f) -> Over . map f <$> mapM semantics' cs
112 Just (Right f) -> Paragraph . Beside . map f<$> mapM iSemantics cs
113
114iSemantics :: ContentTree -> Either String (Inline String)
115iSemantics Empty = Right $ Beside []
116iSemantics (Content str) = Right $ Cooked str
117iSemantics (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
118 Nothing -> unknownTag tag
119 Just (Left f) -> error "Known inline tag sorted within block"
120 Just (Right f) -> Beside . map f <$> mapM iSemantics cs
diff --git a/bbcode/src/BBCode/Syntax.hs b/bbcode/src/BBCode/Syntax.hs
deleted file mode 100644
index a196e05..0000000
--- a/bbcode/src/BBCode/Syntax.hs
+++ /dev/null
@@ -1,108 +0,0 @@
1{-# LANGUAGE RecordWildCards #-}
2
3module BBCode.Syntax
4 ( treeify
5 , ContentForest
6 , ContentTree(..)
7 ) where
8
9import BBCode.Tokenizer (Token(..))
10
11import Data.Foldable
12import Data.Bifunctor
13import Data.Monoid
14
15import Control.Monad.State
16import Control.Monad.Trans
17import Control.Monad
18
19import Data.CaseInsensitive ( CI )
20import qualified Data.CaseInsensitive as CI
21
22import Data.Function (on)
23
24type ContentForest = [ContentTree]
25data ContentTree = Content String
26 | Tagged [ContentTree] String
27 | Empty
28 deriving (Show, Eq)
29
30data Step = Down [ContentTree] [ContentTree] String
31 deriving (Show)
32
33data Zipper = Zipper
34 { hole :: String
35 , prevs :: [ContentTree]
36 , steps :: [Step]
37 }
38 deriving (Show)
39
40type Parser = StateT Zipper (Either String)
41abort :: String -> Parser a
42abort = lift . Left
43
44
45treeify :: [Token] -> Either String ContentForest
46treeify tokenStream = second (postProcess . unZip) $ execStateT (mapM_ incorporate tokenStream) (Zipper "" [] [])
47
48postProcess :: ContentForest -> ContentForest
49postProcess forest = do
50 tree <- forest
51 let
52 tree' = postProcess' tree
53 guard $ tree' /= Empty
54 return tree'
55 where
56 postProcess' :: ContentTree -> ContentTree
57 postProcess' (Content "") = Empty
58 postProcess' (Tagged [] _) = Empty
59 postProcess' (Tagged cs t) = Tagged [c' | c <- cs, let c' = postProcess' c, c' /= Empty ] t
60 postProcess' x = x
61
62unZip :: Zipper -> ContentForest
63unZip Zipper{..} = reverse (apply hole steps : prevs)
64
65apply :: String -> [Step] -> ContentTree
66apply hole steps = hole `apply'` (reverse steps)
67apply' "" [] = Empty
68apply' hole [] = Content hole
69apply' hole (Down pres posts tag:steps) = Tagged (reverse pres ++ [hole `apply` steps] ++ posts) tag
70
71incorporate :: Token -> Parser ()
72incorporate (Text str) = append str
73incorporate (Whitespace str)
74 | delimitsPar str = do
75 currSteps <- gets steps
76 if null currSteps then
77 modify (\Zipper{..} -> Zipper { hole = "", steps = [], prevs = (hole `apply` steps : prevs) })
78 else
79 append str
80 | otherwise = append str
81 where
82 delimitsPar str = (sum . map (const (1 :: Integer)) . filter (== '\n') $ str) >= 1
83incorporate (TagOpen tagName) = modify $ (\z@(Zipper{..}) -> z { steps = (Down [] [] tagName : steps) })
84incorporate (TagClose tagName) = do
85 currSteps <- gets steps
86 case currSteps of
87 [] -> abort $ "Closing unopenend tag: " ++ tagName
88 (Down pres posts tagName':s) -> if ((==) `on` CI.mk) tagName tagName' then
89 goUp
90 else
91 abort $ "Mismatched tags: [" ++ tagName' ++ "]...[/" ++ tagName ++ "]"
92
93append :: String -> Parser ()
94append str = modify (\z@(Zipper{..}) -> z { hole = hole ++ str })
95
96goUp :: Parser ()
97goUp = do
98 (Down pres posts tagName:s) <- gets steps
99 hole <- gets hole
100 let
101 steppedHole = Tagged (reverse pres ++ [Content hole] ++ posts) tagName
102 case s of
103 [] -> modify $ (\z@(Zipper{..}) -> Zipper { hole = "", prevs = steppedHole : prevs, steps = [] })
104 (t:ts) -> do
105 let
106 (Down pres posts tagName) = t
107 t' = Down (steppedHole : pres) posts tagName
108 modify $ (\z -> z { hole = "", steps = (t':ts) })
diff --git a/bbcode/src/BBCode/Tokenizer.hs b/bbcode/src/BBCode/Tokenizer.hs
deleted file mode 100644
index c860c7c..0000000
--- a/bbcode/src/BBCode/Tokenizer.hs
+++ /dev/null
@@ -1,44 +0,0 @@
1{-# LANGUAGE OverloadedStrings #-}
2
3module BBCode.Tokenizer
4 ( Token(..)
5 , tokenize
6 ) where
7
8import qualified Data.Text.Lazy as TL
9import qualified Data.Text as T
10
11import Control.Applicative
12import Data.Attoparsec.Text.Lazy
13
14import Data.Char (isSpace)
15import Data.Monoid (mconcat)
16
17data Token = Text String
18 | Whitespace String
19 | TagOpen String
20 | TagClose String
21 deriving (Show, Read, Eq)
22
23tokenize :: String -> Either String [Token]
24tokenize = eitherResult . parse (tokenize' <* endOfInput) . TL.pack
25
26tokenize' :: Parser [Token]
27tokenize' = many $ choice [ whitespace
28 , Text . T.unpack <$> ("\\" *> "[")
29 , tagClose
30 , tagOpen
31 , text
32 ]
33
34whitespace :: Parser Token
35whitespace = Whitespace <$> many1 space
36
37tagOpen :: Parser Token
38tagOpen = TagOpen . T.unpack <$> ("[" *> takeWhile1 (/= ']') <* "]")
39
40tagClose :: Parser Token
41tagClose = TagClose . T.unpack <$> ("[/" *> takeWhile1 (/= ']') <* "]")
42
43text :: Parser Token
44text = Text . T.unpack <$> takeWhile1 (\c -> not (isSpace c) && notInClass "[" c)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 02:12:57 +0000