diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2015-12-25 17:56:13 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2015-12-25 17:56:13 +0000 |
commit | 9db2c42f4880362cf098358de830415c14f6878c (patch) | |
tree | 2b0b9257f01eec926152746fc2e7646764063c3a /bbcode/src/BBCode.hs | |
parent | 08eee2f0de77ffa631e84ccf734e8e95817b7c81 (diff) | |
download | thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.gz thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.bz2 thermoprint-9db2c42f4880362cf098358de830415c14f6878c.tar.xz thermoprint-9db2c42f4880362cf098358de830415c14f6878c.zip |
Cleaned tree for rewrite
Diffstat (limited to 'bbcode/src/BBCode.hs')
-rw-r--r-- | bbcode/src/BBCode.hs | 120 |
1 files changed, 0 insertions, 120 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 | |||
3 | module BBCode | ||
4 | ( parse | ||
5 | , make | ||
6 | ) where | ||
7 | |||
8 | import Thermoprint | ||
9 | |||
10 | import BBCode.Tokenizer | ||
11 | import BBCode.Syntax | ||
12 | |||
13 | import Data.Maybe | ||
14 | import Data.Monoid | ||
15 | import Data.Either | ||
16 | import Data.Bifunctor | ||
17 | import Data.List | ||
18 | import Data.Ord | ||
19 | import Data.Foldable | ||
20 | |||
21 | import Data.Function (on) | ||
22 | |||
23 | import Data.CaseInsensitive ( CI ) | ||
24 | import qualified Data.CaseInsensitive as CI | ||
25 | |||
26 | import Data.Map ( Map ) | ||
27 | import qualified Data.Map as Map | ||
28 | |||
29 | import Prelude hiding (takeWhile) | ||
30 | |||
31 | import Debug.Trace | ||
32 | |||
33 | knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String)) | ||
34 | knownTags = [ ("center", Left Center) | ||
35 | , ("u", Right Underline) | ||
36 | ] | ||
37 | |||
38 | isBlock, isInline :: String -> Bool | ||
39 | isBlock = testTag isLeft | ||
40 | isInline = testTag isRight | ||
41 | testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags) | ||
42 | |||
43 | data Decorated c = Decorated c [String] | ||
44 | deriving (Show, Eq) | ||
45 | |||
46 | make :: Block String -> String | ||
47 | make (Over blocks) = concat $ map make blocks | ||
48 | make (Center block) = "[center]" ++ make block ++ "[/center]\n" | ||
49 | make (Paragraph inline) = make' inline ++ "\n" | ||
50 | |||
51 | make' :: Inline String -> String | ||
52 | make' (Beside inlines) = concat $ map make' inlines | ||
53 | make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]" | ||
54 | make' (Cooked c) = c | ||
55 | make' (Raw _) = error "Cannot transform block containing raw data to bbcode" | ||
56 | |||
57 | parse :: String -> Either String (Block String) | ||
58 | parse input = massage <$> ((remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics) | ||
59 | |||
60 | massage :: Block String -> Block String | ||
61 | massage (Over [x]) = massage x | ||
62 | massage (Over xs) = Over $ map massage xs | ||
63 | massage (Center x) = Center $ massage x | ||
64 | massage (Paragraph x) = Paragraph $ massage' x | ||
65 | |||
66 | massage' :: Inline String -> Inline String | ||
67 | massage' (Beside [x]) = massage' x | ||
68 | massage' (Beside xs) = Beside $ map massage' xs | ||
69 | massage' (Underline x) = Underline $ massage' x | ||
70 | massage' z = z | ||
71 | |||
72 | blockify :: ContentForest -> [Decorated String] | ||
73 | blockify = 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 | |||
83 | remerge :: [Decorated String] -> ContentForest | ||
84 | remerge [] = [] | ||
85 | remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c] | ||
86 | where | ||
87 | applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco | ||
88 | remerge 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 | |||
100 | unknownTag :: forall a. String -> Either String a | ||
101 | unknownTag tag = Left $ "Unknown tag: " ++ tag | ||
102 | |||
103 | semantics :: ContentForest -> Either String (Block String) | ||
104 | semantics forest = Over <$> mapM semantics' forest | ||
105 | |||
106 | semantics' :: ContentTree -> Either String (Block String) | ||
107 | semantics' Empty = Right $ Over [] | ||
108 | semantics' (Content str) = Right $ Paragraph (Cooked str) | ||
109 | semantics' (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 | |||
114 | iSemantics :: ContentTree -> Either String (Inline String) | ||
115 | iSemantics Empty = Right $ Beside [] | ||
116 | iSemantics (Content str) = Right $ Cooked str | ||
117 | iSemantics (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 | ||