prototype: BBCode.DomForest -> Printout

1 files 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