From 3c0383695b1c1e1a6f7b3f6811dacaa32577f9f7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 18 Jan 2016 05:42:41 +0000 Subject: prototype: BBCode.DomForest -> Printout --- spec/src/Thermoprint/Printout/BBCode.hs | 95 +++++++++++++++++++++++++++------ 1 file changed, 78 insertions(+), 17 deletions(-) diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs index cee36b8..8df70c0 100644 --- a/spec/src/Thermoprint/Printout/BBCode.hs +++ b/spec/src/Thermoprint/Printout/BBCode.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} -- | Use 'Text.BBCode' to parse BBCode module Thermoprint.Printout.BBCode @@ -12,11 +13,14 @@ module Thermoprint.Printout.BBCode import Data.Text (Text) import qualified Data.Text as T (unpack) +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text.Lazy as TL (fromStrict) + import Data.Map (Map) import qualified Data.Map as Map (lookup) import Data.Sequence (Seq) -import qualified Data.Sequence as Seq () +import qualified Data.Sequence as Seq (fromList, singleton) import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -32,7 +36,7 @@ import Text.Read (readMaybe) import Data.Maybe (fromMaybe) -import Text.BBCode (DomTree(..), TreeError(..)) +import Text.BBCode (DomForest, DomTree(..), TreeError(..)) import qualified Text.BBCode as Raw (bbcode, BBCodeError(..)) import Thermoprint.Printout @@ -45,30 +49,87 @@ data BBCodeError = LexerError String -- ^ Error while parsing input to stream of instance Exception BBCodeError +morph' :: Raw.BBCodeError -> BBCodeError +-- ^ Transform 'Raw.BBCodeError' to 'BBCodeError' +morph' (Raw.LexerError x) = LexerError x +morph' (Raw.TreeError x) = TreeError x + -- ^ 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 +data SemanticError = BlockInLineContext -- ^ A 'Block' structure was encountered when a 'Line' was expected + | LineInBlockContext -- ^ A 'Line' structure was encountered when a 'Block' was expected + | UnmappedBlockElement Text -- ^ We encountered an 'Element' that, in a 'Block' context, does not map to any structure + | UnmappedLineElement Text -- ^ We encountered an 'Element' that, in a 'Line' context, does not map to any structure deriving (Show, Eq, Generic, Typeable) instance Exception SemanticError +-- | Result of parsing a single 'DomTree' +data ParseResult = RBlock Block -- ^ Parses only as 'Block' + | RLine Line -- ^ Parses only as 'Line' + | RAmbiguous Block Line -- ^ Parses as either 'Block' or 'Line' depending on context + | RNoParse SemanticError SemanticError -- ^ Does not parse as either 'Block' or 'Line' + +-- | Current parser context +data Context a where + BlockCtx :: Context Block -- ^ Parsing 'Block's + LineCtx :: Context Line -- ^ Parsing 'Line's + +extract :: Context a -> ParseResult -> Either SemanticError a +-- ^ Extract information from a 'ParseResult' given 'Context' +extract BlockCtx (RBlock b) = Right b +extract LineCtx (RLine l) = Right l +extract BlockCtx (RAmbiguous b _) = Right b +extract LineCtx (RAmbiguous _ l) = Right l +extract BlockCtx (RNoParse bErr _) = Left bErr +extract LineCtx (RNoParse _ lErr) = Left lErr +extract BlockCtx _ = Left LineInBlockContext +extract LineCtx _ = Left BlockInLineContext + 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) +morph :: DomForest -> Either SemanticError Printout +-- ^ Parse a list of paragraphs +-- +-- Since we permit only cooked input via 'Raw' 'Paragraph' is identical to 'Block' +morph f = Seq.fromList <$> mapM (\t -> Seq.singleton . Cooked <$> parse BlockCtx t) f + +parseDom :: DomTree -> ParseResult +-- ^ Invoke 'asLine' and 'asBlock' to parse a single 'DomTree' +parseDom (Content t) = either RBlock (\l -> RAmbiguous (Line l) l) . text . TL.fromStrict $ t +parseDom (Element t attrs cs) + | Right blockParse' <- blockParse + , Right lineParse' <- lineParse = RAmbiguous blockParse' lineParse' + | Right blockParse' <- blockParse = RBlock blockParse' + | Right lineParse' <- lineParse = RLine lineParse' + | Left bErr <- blockParse + , Left lErr <- lineParse = RNoParse bErr lErr + where + blockParse = asBlock t cs attrs + lineParse = asLine t cs attrs + +mergeResult :: Monoid a => Context a -> [ParseResult] -> Either SemanticError a +-- ^ Merge a list of 'ParseResults' in a certain 'Context' +mergeResult _ [] = Right mempty +mergeResult BlockCtx xs@((RLine _):_) = bimap (const LineInBlockContext) Line $ mergeResult LineCtx xs +mergeResult ctx (amb@(RAmbiguous _ _):xs) = mappend <$> extract ctx amb <*> mergeResult ctx xs +mergeResult ctx (err@(RNoParse _ _):_) = extract ctx err +mergeResult ctx (x:xs) = mappend <$> extract ctx x <*> mergeResult ctx xs + +parse :: Monoid a => Context a -> [DomTree] -> Either SemanticError a +-- ^ Parse a list of 'DomTree's in a certain 'Context' +-- +-- @parse ctx = 'mergeResult' ctx . map 'parseDom'@ +parse ctx = mergeResult ctx . map parseDom lookupAttr :: Read a => CI Text -> a -> Map (CI Text) Text -> a lookupAttr t def attrs = fromMaybe def $ Map.lookup t attrs >>= (readMaybe . T.unpack) + +asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block +asBlock "VSpace" [] = Right . VSpace . lookupAttr "height" 1 +asBlock t _ = const $ Left . UnmappedBlockElement . CI.original $ t + +asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line +asLine "HSpace" [] = Right . HSpace . lookupAttr "width" 1 +asLine t _ = const $ Left . UnmappedLineElement . CI.original $ t -- cgit v1.2.3