blob: cee36b8b002163d819d012b66191da3d95298eae (
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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
-- | Use 'Text.BBCode' to parse BBCode
module Thermoprint.Printout.BBCode
( bbcode
, BBCodeError(..)
, TreeError(..)
, SemanticError(..)
) where
import Data.Text (Text)
import qualified Data.Text as T (unpack)
import Data.Map (Map)
import qualified Data.Map as Map (lookup)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq ()
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import GHC.Generics (Generic)
import Control.Exception (Exception)
import Data.Typeable (Typeable)
import Data.Bifunctor (bimap, first)
import Control.Monad (join)
import Text.Read (readMaybe)
import Data.Maybe (fromMaybe)
import Text.BBCode (DomTree(..), TreeError(..))
import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
import Thermoprint.Printout
-- ^ We replicate 'Raw.BBCodeError' but add a new failure mode documenting incompatibly of the parsed syntax tree with our document format
data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens
| TreeError TreeError -- ^ Error while parsing stream of tokens to syntax tree
| SemanticError SemanticError -- ^ Error while mapping syntax tree to document format
deriving (Show, Eq, Generic, Typeable)
instance Exception BBCodeError
-- ^ An error ocurred while parsing the DOM-Forest (`['DomTree']`)
data SemanticError = UnmappedTag Text -- ^ An `Element` does not map to any structure in the context it occurred in
deriving (Show, Eq, Generic, Typeable)
instance Exception SemanticError
bbcode :: Text -> Either BBCodeError Printout
-- ^ Parse BBCode
bbcode = join . fmap (first SemanticError) . bimap morph' morph . Raw.bbcode
morph' :: Raw.BBCodeError -> BBCodeError
morph' (Raw.LexerError x) = LexerError x
morph' (Raw.TreeError x) = TreeError x
morph :: [DomTree] -> Either SemanticError Printout
morph = undefined
asBlock :: CI Text -> Map (CI Text) Text -> Either SemanticError Block
asBlock "VSpace" = Right . VSpace . lookupAttr "size" 1
asBlock t = Left . const (UnmappedTag . CI.original $ t)
asLine :: CI Text -> Map (CI Text) Text -> Either SemanticError Line
asLine "HSpace" = Right . HSpace . lookupAttr "size" 1
asLine t = Left . const (UnmappedTag . CI.original $ t)
lookupAttr :: Read a => CI Text -> a -> Map (CI Text) Text -> a
lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= (readMaybe . T.unpack)
|
