Moved handling of lines in block context

Now allows arbitrary (instead of prefix only) switching between block
and line contexts

1 files changed, 21 insertions, 3 deletions

diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs
index 8825732..ce2aa43 100644
--- a/spec/src/Thermoprint/Printout/BBCode.hs
+++ b/spec/src/Thermoprint/Printout/BBCode.hs
@@ -29,6 +29,8 @@ import Data.Typeable (Typeable)
 import Data.Bifunctor (bimap, first)
 import Control.Monad (join)
 
+import Data.List (groupBy)
+
 import Text.BBCode (DomForest, DomTree(..), TreeError(..))
 import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
 
@@ -63,6 +65,7 @@ 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'
+                 deriving (Show)
 
 -- | Current parser context
 data Context a where
@@ -80,6 +83,16 @@ extract LineCtx  (RNoParse _ lErr) = Left lErr
 extract BlockCtx _                 = Left LineInBlockContext
 extract LineCtx  _                 = Left BlockInLineContext
 
+hasBlockCtx :: ParseResult -> Bool
+-- ^ Result can be 'extract'ed in a 'Block' 'Context'
+hasBlockCtx (RLine _) = False
+hasBlockCtx _         = True
+
+hasLineCtx :: ParseResult -> Bool
+-- ^ Result can be 'extract'ed in a 'Line' 'Context'
+hasLineCtx (RBlock _) = False
+hasLineCtx _          = True
+
 bbcode :: Text -> Either BBCodeError Printout
 -- ^ Parse BBCode
 bbcode = join . fmap (first SemanticError) . bimap morph' morph . Raw.bbcode
@@ -88,7 +101,7 @@ 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
+morph = fmap Seq.fromList . mapM (\t -> Seq.singleton . Cooked <$> parse BlockCtx t)
 
 parseDom :: DomTree -> ParseResult
 -- ^ Invoke 'asLine' and 'asBlock' to parse a single 'DomTree'
@@ -107,7 +120,6 @@ parseDom (Element t attrs cs)
 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
@@ -116,7 +128,13 @@ 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
+parse BlockCtx = fmap mconcat . mapM mergeResult' . groupBy sameCtx . map parseDom
+  where
+    sameCtx a b = (hasLineCtx a && hasLineCtx b) || (hasBlockCtx a && hasBlockCtx b)
+    mergeResult' xs
+      | hasLineCtx `all` xs = Line <$> mergeResult LineCtx xs
+      | otherwise           = mergeResult BlockCtx xs
+parse ctx      = mergeResult ctx . map parseDom
 
 asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block
 asBlock "VSpace" _  = Right . VSpace . lookupAttr "height" True 1