diff options
Diffstat (limited to 'bbcode/src/BBCode.hs')
-rw-r--r-- | bbcode/src/BBCode.hs | 96 |
1 files changed, 96 insertions, 0 deletions
diff --git a/bbcode/src/BBCode.hs b/bbcode/src/BBCode.hs new file mode 100644 index 0000000..750fb0f --- /dev/null +++ b/bbcode/src/BBCode.hs | |||
@@ -0,0 +1,96 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, OverloadedLists, RankNTypes, ImpredicativeTypes #-} | ||
2 | |||
3 | module BBCode | ||
4 | ( parse | ||
5 | ) where | ||
6 | |||
7 | import Thermoprint | ||
8 | |||
9 | import BBCode.Tokenizer | ||
10 | import BBCode.Syntax | ||
11 | |||
12 | import Data.Maybe | ||
13 | import Data.Monoid | ||
14 | import Data.Either | ||
15 | import Data.Bifunctor | ||
16 | import Data.List | ||
17 | import Data.Ord | ||
18 | import Data.Foldable | ||
19 | |||
20 | import Data.Function (on) | ||
21 | |||
22 | import Data.CaseInsensitive ( CI ) | ||
23 | import qualified Data.CaseInsensitive as CI | ||
24 | |||
25 | import Data.Map ( Map ) | ||
26 | import qualified Data.Map as Map | ||
27 | |||
28 | import Prelude hiding (takeWhile) | ||
29 | |||
30 | import Debug.Trace | ||
31 | |||
32 | knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String)) | ||
33 | knownTags = [ ("center", Left Center) | ||
34 | , ("u", Right Underline) | ||
35 | ] | ||
36 | |||
37 | isBlock, isInline :: String -> Bool | ||
38 | isBlock = testTag isLeft | ||
39 | isInline = testTag isRight | ||
40 | testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags) | ||
41 | |||
42 | data Decorated c = Decorated c [String] | ||
43 | deriving (Show, Eq) | ||
44 | |||
45 | parse :: String -> Either String (Block String) | ||
46 | parse input = (remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics | ||
47 | |||
48 | blockify :: ContentForest -> [Decorated String] | ||
49 | blockify = map sortDeco . concat . map (blockify' []) | ||
50 | where | ||
51 | blockify' _ Empty = [] | ||
52 | blockify' initial (Content str) = [str `Decorated` initial] | ||
53 | blockify' initial (Tagged cs tag) = concat $ map (blockify' $ tag : initial) cs | ||
54 | sortDeco :: Decorated c -> Decorated c | ||
55 | sortDeco (Decorated c tags) = Decorated c $ (nubBy ((==) `on` CI.mk) . sortBy blockiness) tags | ||
56 | blockiness :: String -> String -> Ordering | ||
57 | blockiness a b = comparing isBlock a b <> comparing CI.mk a b -- sort also alphabetically for the benefit of remerge | ||
58 | |||
59 | remerge :: [Decorated String] -> ContentForest | ||
60 | remerge [] = [] | ||
61 | remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c] | ||
62 | where | ||
63 | applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco | ||
64 | remerge xs = concat $ map toTree $ groupLasts xs | ||
65 | where | ||
66 | groupLasts = groupBy ((==) `on` (listToMaybe . reverse . (\(Decorated _ ds) -> ds))) | ||
67 | -- toTree :: [Decorated String] -> [ContentTree] | ||
68 | toTree [] = [] | ||
69 | toTree (x@(Decorated _ []):xs) = map (Content . (\(Decorated c []) -> c)) (x:xs) | ||
70 | toTree (x@(Decorated _ ds):xs) = [Tagged content tag] | ||
71 | where | ||
72 | tag = last ds | ||
73 | content = toTree $ map stripLast (x:xs) | ||
74 | stripLast (Decorated c ds) = Decorated c (init ds) | ||
75 | |||
76 | unknownTag :: forall a. String -> Either String a | ||
77 | unknownTag tag = Left $ "Unknown tag: " ++ tag | ||
78 | |||
79 | semantics :: ContentForest -> Either String (Block String) | ||
80 | semantics forest = Over <$> mapM semantics' forest | ||
81 | |||
82 | semantics' :: ContentTree -> Either String (Block String) | ||
83 | semantics' Empty = Right $ Over [] | ||
84 | semantics' (Content str) = Right $ Paragraph (Cooked str) | ||
85 | semantics' (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of | ||
86 | Nothing -> unknownTag tag | ||
87 | Just (Left f) -> Over . map f <$> mapM semantics' cs | ||
88 | Just (Right f) -> Paragraph . Beside . map f<$> mapM iSemantics cs | ||
89 | |||
90 | iSemantics :: ContentTree -> Either String (Inline String) | ||
91 | iSemantics Empty = Right $ Beside [] | ||
92 | iSemantics (Content str) = Right $ Cooked str | ||
93 | iSemantics (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of | ||
94 | Nothing -> unknownTag tag | ||
95 | Just (Left f) -> error "Known inline tag sorted within block" | ||
96 | Just (Right f) -> Beside . map f <$> mapM iSemantics cs | ||