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