diff options
Diffstat (limited to 'bbcode/src/BBCode')
| -rw-r--r-- | bbcode/src/BBCode/Syntax.hs | 108 | ||||
| -rw-r--r-- | bbcode/src/BBCode/Tokenizer.hs | 44 |
2 files changed, 0 insertions, 152 deletions
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 | |||
| 3 | module BBCode.Syntax | ||
| 4 | ( treeify | ||
| 5 | , ContentForest | ||
| 6 | , ContentTree(..) | ||
| 7 | ) where | ||
| 8 | |||
| 9 | import BBCode.Tokenizer (Token(..)) | ||
| 10 | |||
| 11 | import Data.Foldable | ||
| 12 | import Data.Bifunctor | ||
| 13 | import Data.Monoid | ||
| 14 | |||
| 15 | import Control.Monad.State | ||
| 16 | import Control.Monad.Trans | ||
| 17 | import Control.Monad | ||
| 18 | |||
| 19 | import Data.CaseInsensitive ( CI ) | ||
| 20 | import qualified Data.CaseInsensitive as CI | ||
| 21 | |||
| 22 | import Data.Function (on) | ||
| 23 | |||
| 24 | type ContentForest = [ContentTree] | ||
| 25 | data ContentTree = Content String | ||
| 26 | | Tagged [ContentTree] String | ||
| 27 | | Empty | ||
| 28 | deriving (Show, Eq) | ||
| 29 | |||
| 30 | data Step = Down [ContentTree] [ContentTree] String | ||
| 31 | deriving (Show) | ||
| 32 | |||
| 33 | data Zipper = Zipper | ||
| 34 | { hole :: String | ||
| 35 | , prevs :: [ContentTree] | ||
| 36 | , steps :: [Step] | ||
| 37 | } | ||
| 38 | deriving (Show) | ||
| 39 | |||
| 40 | type Parser = StateT Zipper (Either String) | ||
| 41 | abort :: String -> Parser a | ||
| 42 | abort = lift . Left | ||
| 43 | |||
| 44 | |||
| 45 | treeify :: [Token] -> Either String ContentForest | ||
| 46 | treeify tokenStream = second (postProcess . unZip) $ execStateT (mapM_ incorporate tokenStream) (Zipper "" [] []) | ||
| 47 | |||
| 48 | postProcess :: ContentForest -> ContentForest | ||
| 49 | postProcess 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 | |||
| 62 | unZip :: Zipper -> ContentForest | ||
| 63 | unZip Zipper{..} = reverse (apply hole steps : prevs) | ||
| 64 | |||
| 65 | apply :: String -> [Step] -> ContentTree | ||
| 66 | apply hole steps = hole `apply'` (reverse steps) | ||
| 67 | apply' "" [] = Empty | ||
| 68 | apply' hole [] = Content hole | ||
| 69 | apply' hole (Down pres posts tag:steps) = Tagged (reverse pres ++ [hole `apply` steps] ++ posts) tag | ||
| 70 | |||
| 71 | incorporate :: Token -> Parser () | ||
| 72 | incorporate (Text str) = append str | ||
| 73 | incorporate (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 | ||
| 83 | incorporate (TagOpen tagName) = modify $ (\z@(Zipper{..}) -> z { steps = (Down [] [] tagName : steps) }) | ||
| 84 | incorporate (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 | |||
| 93 | append :: String -> Parser () | ||
| 94 | append str = modify (\z@(Zipper{..}) -> z { hole = hole ++ str }) | ||
| 95 | |||
| 96 | goUp :: Parser () | ||
| 97 | goUp = 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 | |||
| 3 | module BBCode.Tokenizer | ||
| 4 | ( Token(..) | ||
| 5 | , tokenize | ||
| 6 | ) where | ||
| 7 | |||
| 8 | import qualified Data.Text.Lazy as TL | ||
| 9 | import qualified Data.Text as T | ||
| 10 | |||
| 11 | import Control.Applicative | ||
| 12 | import Data.Attoparsec.Text.Lazy | ||
| 13 | |||
| 14 | import Data.Char (isSpace) | ||
| 15 | import Data.Monoid (mconcat) | ||
| 16 | |||
| 17 | data Token = Text String | ||
| 18 | | Whitespace String | ||
| 19 | | TagOpen String | ||
| 20 | | TagClose String | ||
| 21 | deriving (Show, Read, Eq) | ||
| 22 | |||
| 23 | tokenize :: String -> Either String [Token] | ||
| 24 | tokenize = eitherResult . parse (tokenize' <* endOfInput) . TL.pack | ||
| 25 | |||
| 26 | tokenize' :: Parser [Token] | ||
| 27 | tokenize' = many $ choice [ whitespace | ||
| 28 | , Text . T.unpack <$> ("\\" *> "[") | ||
| 29 | , tagClose | ||
| 30 | , tagOpen | ||
| 31 | , text | ||
| 32 | ] | ||
| 33 | |||
| 34 | whitespace :: Parser Token | ||
| 35 | whitespace = Whitespace <$> many1 space | ||
| 36 | |||
| 37 | tagOpen :: Parser Token | ||
| 38 | tagOpen = TagOpen . T.unpack <$> ("[" *> takeWhile1 (/= ']') <* "]") | ||
| 39 | |||
| 40 | tagClose :: Parser Token | ||
| 41 | tagClose = TagClose . T.unpack <$> ("[/" *> takeWhile1 (/= ']') <* "]") | ||
| 42 | |||
| 43 | text :: Parser Token | ||
| 44 | text = Text . T.unpack <$> takeWhile1 (\c -> not (isSpace c) && notInClass "[" c) | ||
