Implement parsing of optional YAML block

README.md

@@ -28,8 +28,7 @@ Another difference between Common Mark and MMark is that the latter supports
 more common markdown extensions out-of-the-box. In particular, MMark
 supports:
 
-* parsing of optional YAML metadata block (NOT YET)
-* automatic turning of bare URIs into links (NOT YET)
+* parsing of optional YAML block
 * strikeout using `~~this~~` syntax
 * superscript using `^this^` syntax
 * subscript using `~this~` syntax
@@ -155,9 +154,6 @@ it.
 
 ### Other differences
 
-Other differences/incompatibilities with Common Mark specification include
-(the list will hopefully get shorter as the library matures):
-
 * Fenced code blocks must be explicitly closed by a closing fence. They are
   not closed by the end of document or by start of another block.
 * MMark does not support hard line breaks represented as double space before
@@ -182,6 +178,11 @@ Other differences/incompatibilities with Common Mark specification include
 * HTML inlines are not supported yet.
 * Entity and numeric character references are not supported yet.
 
+### Additional information about MMark-specific extensions
+
+* YAML block must start with three hyphens `---` and end with three hyphens
+  `---`. It can only be placed at the beginning of markdown document.
+
 ## Contribution
 
 Issues, bugs, and questions may be reported in

Text/MMark.hs

@@ -29,8 +29,7 @@
 -- supports more common markdown extensions out-of-the-box. In particular,
 -- MMark supports:
 --
---     * parsing of optional YAML metadata block (NOT YET)
---     * automatic turning of bare URIs into links (NOT YET)
+--     * parsing of optional YAML block
 --     * strikeout using @~~this~~@ syntax
 --     * superscript using @^this^@ syntax
 --     * subscript using @~this~@ syntax

Text/MMark/Parser.hs

@@ -28,15 +28,17 @@ module Text.MMark.Parser
 where
 
 import Control.Applicative
+import Control.Arrow (first)
 import Control.Monad
 import Control.Monad.State.Strict
 import Data.Data (Data)
 import Data.Default.Class
 import Data.List.NonEmpty (NonEmpty (..), (<|))
-import Data.Maybe (isNothing, isJust, fromJust)
+import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)
 import Data.Semigroup ((<>))
 import Data.Text (Text)
 import Data.Typeable (Typeable)
+import Data.Void
 import GHC.Generics
 import Text.MMark.Internal
 import Text.Megaparsec hiding (parse)
@@ -48,6 +50,7 @@ import qualified Data.List.NonEmpty                       as NE
 import qualified Data.Set                                 as E
 import qualified Data.Text                                as T
 import qualified Data.Text.Encoding                       as TE
+import qualified Data.Yaml                                as Yaml
 import qualified Text.Email.Validate                      as Email
 import qualified Text.Megaparsec.Char.Lexer               as L
 import qualified Text.URI                                 as URI
@@ -62,13 +65,18 @@ type Parser = Parsec MMarkErr Text
 -- | MMark custom parse errors.
 
 data MMarkErr
-  = NonFlankingDelimiterRun (NonEmpty Char)
+  = YamlParseError String
+    -- ^ YAML error that occurred during parsing of a YAML block
+  | NonFlankingDelimiterRun (NonEmpty Char)
     -- ^ This delimiter run should be in left- or right- flanking position
   deriving (Eq, Ord, Show, Read, Generic, Typeable, Data)
 
 instance ShowErrorComponent MMarkErr where
-  showErrorComponent (NonFlankingDelimiterRun dels) =
-    showTokens dels ++ " should be in left- or right- flanking position"
+  showErrorComponent = \case
+    YamlParseError str ->
+      "YAML parse error: " ++ str
+    NonFlankingDelimiterRun dels ->
+      showTokens dels ++ " should be in left- or right- flanking position"
 
 -- | Parser type for inlines.
 
@@ -141,11 +149,11 @@ parse
   -> Either (NonEmpty (ParseError Char MMarkErr)) MMark
      -- ^ Parse errors or parsed document
 parse file input =
-  case runParser pBlocks file input of
+  case runParser ((,) <$> optional pYamlBlock <*> pBlocks) file input of
     -- NOTE This parse error only happens when document structure on block
     -- level cannot be parsed, which should not normally happen.
     Left err -> Left (nes err)
-    Right blocks ->
+    Right (myaml, blocks) ->
       let parsed = fmap (runIsp (pInlines def <* eof)) <$> blocks
           getErrs (Left e) es = replaceEof "end of inline block" e : es
           getErrs _        es = es
@@ -154,11 +162,31 @@ parse file input =
             error "Text.MMark.Parser.parse: impossible happened"
       in case NE.nonEmpty (foldMap (foldr getErrs []) parsed) of
            Nothing -> Right MMark
-             { mmarkYaml      = Nothing
+             { mmarkYaml      = myaml
              , mmarkBlocks    = fmap fromRight <$> parsed
              , mmarkExtension = mempty }
            Just es -> Left es
 
+pYamlBlock :: Parser Yaml.Value
+pYamlBlock = do
+  dpos <- getPosition
+  void (string "---")
+  let go = do
+        l <- takeWhileP Nothing notNewline
+        void (optional eol)
+        e <- atEnd
+        if e || l == "---"
+          then return []
+          else (l :) <$> go
+  ls <- go
+  case (Yaml.decodeEither . TE.encodeUtf8 . T.intercalate "\n") ls of
+    Left err' -> do
+      let (apos, err) = splitYamlError (sourceName dpos) err'
+      setPosition (fromMaybe dpos apos)
+      (fancyFailure . E.singleton . ErrorCustom . YamlParseError) err
+    Right v ->
+      return v
+
 pBlocks :: Parser [Block Isp]
 pBlocks = do
   setTabWidth (mkPos 4)
@@ -730,3 +758,16 @@ isEmailUri uri =
 
 mailtoScheme :: URI.RText 'URI.Scheme
 mailtoScheme = fromJust (URI.mkScheme "mailto")
+
+splitYamlError :: FilePath -> String -> (Maybe SourcePos, String)
+splitYamlError file str = maybe (Nothing, str) (first pure) (parseMaybe p str)
+  where
+    p :: Parsec Void String (SourcePos, String)
+    p = do
+      void (string "YAML parse exception at line ")
+      l <- mkPos . (+ 1) <$> L.decimal
+      void (string ", column ")
+      c <- mkPos . (+ 1) <$> L.decimal
+      void (string ":\n")
+      r <- takeRest
+      return (SourcePos file l c, r)

mmark.cabal

@@ -38,6 +38,7 @@ library
                     , mtl              >= 2.0  && < 3.0
                     , parser-combinators >= 0.2 && < 1.0
                     , text             >= 0.2  && < 1.3
+                    , yaml             >= 0.8.10 && < 0.9
   if !impl(ghc >= 8.0)
     build-depends:    semigroups       == 0.18.*
   if !impl(ghc >= 7.10)
@@ -58,7 +59,8 @@ test-suite tests
   main-is:            Spec.hs
   hs-source-dirs:     tests
   type:               exitcode-stdio-1.0
-  build-depends:      base             >= 4.8  && < 5.0
+  build-depends:      aeson            >= 0.11 && < 1.3
+                    , base             >= 4.8  && < 5.0
                     , foldl            >= 1.2  && < 1.4
                     , hspec            >= 2.0  && < 3.0
                     , hspec-megaparsec >= 1.0  && < 2.0

tests/Text/MMarkSpec.hs

@@ -3,6 +3,7 @@
 
 module Text.MMarkSpec (spec) where
 
+import Data.Aeson
 import Data.Char
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Monoid
@@ -1085,10 +1086,20 @@ spec = parallel $ do
       it "returns Nothing" $ do
         doc <- mkDoc "Here we go."
         MMark.projectYaml doc `shouldBe` Nothing
-    context "when document contains a YAML section" $
-      it "return the YAML section" $ do
-        doc <- mkDoc "---\nx: 100\ny: 200\n---Here we go."
-        MMark.projectYaml doc `shouldBe` Nothing -- FIXME when we support YAML blocks
+    context "when document contains a YAML section" $ do
+      context "when it is valid" $
+        it "returns the YAML section" $ do
+          doc <- mkDoc "---\nx: 100\ny: 200\n---Here we go."
+          let r = object
+                [ "x" .= Number 100
+                , "y" .= Number 200 ]
+          MMark.projectYaml doc `shouldBe` Just r
+      context "when it is invalid" $
+        it "signal correct parse error" $
+          let s = "---\nx: 100\ny: x:\n---Here we go."
+          in s ~-> errFancy (posN 15 s)
+             (fancy . ErrorCustom . YamlParseError $
+              "mapping values are not allowed in this context")
 
 ----------------------------------------------------------------------------
 -- Testing extensions