diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## MMark 0.0.7.0 + +* Added GHCJS support by making `yaml` dependency optional. With GHCJS a + yaml block simply always returns the empty object. + ## MMark 0.0.6.2 * Fixed setting offset after parsing of collapsed reference links. diff --git a/Text/MMark/Parser.hs b/Text/MMark/Parser.hs --- a/Text/MMark/Parser.hs +++ b/Text/MMark/Parser.hs @@ -9,6 +9,7 @@ -- -- MMark markdown parser. +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -43,6 +44,7 @@ import Text.URI (URI) import Text.URI.Lens (uriPath) import qualified Control.Monad.Combinators.NonEmpty as NE +import qualified Data.Aeson as Aeson import qualified Data.Char as Char import qualified Data.DList as DList import qualified Data.HashMap.Strict as HM @@ -50,11 +52,14 @@ 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 +#if !defined(ghcjs_HOST_OS) +import qualified Data.Yaml as Yaml +#endif + ---------------------------------------------------------------------------- -- Auxiliary data types @@ -121,7 +126,7 @@ -- | Parse an MMark document on block level. -pMMark :: BParser (Maybe Yaml.Value, [Block Isp]) +pMMark :: BParser (Maybe Aeson.Value, [Block Isp]) pMMark = do meyaml <- optional pYamlBlock blocks <- pBlocks @@ -134,11 +139,11 @@ Just (Right yaml) -> (Just yaml, blocks) --- | Parse a YAML block. On success return the actual parsed 'Yaml.Value' in +-- | Parse a YAML block. On success return the actual parsed 'Aeson.Value' in -- 'Right', otherwise return 'SourcePos' of parse error and 'String' -- describing the error as generated by the @yaml@ package in 'Left'. -pYamlBlock :: BParser (Either (Int, String) Yaml.Value) +pYamlBlock :: BParser (Either (Int, String) Aeson.Value) pYamlBlock = do string "---" *> sc' *> eol let go acc = do @@ -150,12 +155,7 @@ else go (acc . (l:)) doffset <- getOffset ls <- go id <*> ([] <$ sc) - return $ - case (Yaml.decodeEither' . TE.encodeUtf8 . T.intercalate "\n") ls of - Left err' -> - let (moffset, err) = splitYamlError err' - in Left (maybe doffset (+ doffset) moffset, err) - Right v -> Right v + return $ decodeYaml ls doffset -- | Parse several (possibly zero) blocks in a row. @@ -1144,6 +1144,21 @@ else Nothing _ -> Nothing +-- | Decode the yaml block to a 'Aeson.Value'. On GHCJs, without access to +-- libyaml we just return an empty object. It's worth using a pure haskell +-- parser later if this is unacceptable for someone's needs. + +decodeYaml :: [T.Text] -> Int -> (Either (Int,String) Aeson.Value) +#ifdef ghcjs_HOST_OS +decodeYaml _ _ = pure $ Aeson.object [] +#else +decodeYaml ls doffset = + case (Yaml.decodeEither' . TE.encodeUtf8 . T.intercalate "\n") ls of + Left err' -> + let (moffset, err) = splitYamlError err' + in Left (maybe doffset (+ doffset) moffset, err) + Right v -> Right v + splitYamlError :: Yaml.ParseException -> (Maybe Int, String) @@ -1173,6 +1188,7 @@ ++ ", value: " ++ show value ) Yaml.CyclicIncludes -> (Nothing, "cyclic includes") +#endif emptyIspSpan :: Isp emptyIspSpan = IspSpan 0 "" diff --git a/mmark.cabal b/mmark.cabal --- a/mmark.cabal +++ b/mmark.cabal @@ -1,7 +1,7 @@ name: mmark -version: 0.0.6.2 +version: 0.0.7.0 cabal-version: 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.3 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5 license: BSD3 license-file: LICENSE.md author: Mark Karpov @@ -47,13 +47,15 @@ , text >= 0.2 && < 1.3 , text-metrics >= 0.3 && < 0.4 , unordered-containers >= 0.2.5 && < 0.3 - , yaml >= 0.8.10 && < 0.12 + if !impl(ghcjs) + build-depends: yaml >= 0.8.10 && < 0.12 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* if !impl(ghc >= 7.10) build-depends: void == 0.7.* if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* + exposed-modules: Text.MMark , Text.MMark.Extension other-modules: Text.MMark.Parser @@ -73,6 +75,9 @@ -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + if impl(ghcjs) + ghcjs-options: +RTS -K1G -RTS -Wall + default-language: Haskell2010 test-suite tests @@ -90,7 +95,6 @@ , mmark , modern-uri >= 0.3 && < 0.4 , text >= 0.2 && < 1.3 - build-tools: hspec-discover >= 2.0 && < 3.0 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* other-modules: Text.MMarkSpec @@ -100,6 +104,10 @@ ghc-options: -O0 -Wall -Werror else ghc-options: -O2 -Wall + + if impl(ghcjs) + ghcjs-options: -O0 +RTS -K1G -M5G -RTS -Wall -Wwarn=missing-home-modules + default-language: Haskell2010 benchmark bench-speed @@ -114,6 +122,10 @@ ghc-options: -O2 -Wall -Werror else ghc-options: -O2 -Wall + + if impl(ghcjs) + ghcjs-options: -O0 +RTS -K1G -M6G -RTS -Wall -Wwarn=missing-home-modules + default-language: Haskell2010 benchmark bench-memory @@ -128,4 +140,8 @@ ghc-options: -O2 -Wall -Werror else ghc-options: -O2 -Wall + + if impl(ghcjs) + ghcjs-options: -O0 +RTS -K1G -M6G -RTS -Wall -Wwarn=missing-home-modules + default-language: Haskell2010 diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -1,1 +1,7 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +module Main (main) where + +import Test.Hspec +import Text.MMarkSpec (spec) + +main :: IO () +main = hspec spec diff --git a/tests/Text/MMark/TestUtils.hs b/tests/Text/MMark/TestUtils.hs --- a/tests/Text/MMark/TestUtils.hs +++ b/tests/Text/MMark/TestUtils.hs @@ -8,10 +8,13 @@ , (~~->) , (~->) , (=->) - , (==->) ) + , (==->) + , (##->) + ) where import Control.Monad +import Data.Semigroup ((<>)) import Data.Text (Text) import Test.Hspec import Text.MMark (MMark, MMarkErr) @@ -117,3 +120,15 @@ input ==-> expected = do input =-> expected mappend input "\n" =-> expected + +-- | Just like @('==->')@, but the expectation is set with a 'Lucid.Html' +-- instead. This is useful when there are multiple attributes in the +-- outputted HTML, which can cause GHCJs and GHC to output different strings +-- (as Lucid uses an unordered map underneath for the attributes and GHCJs +-- and GHC have different hashing functions). + +(##->) + :: Text -- ^ Input for MMark parser + -> L.Html () -- ^ Lucid builder to match against + -> Expectation +input ##-> expected = input ==-> (TL.toStrict (L.renderText expected) <> "\n") diff --git a/tests/Text/MMarkSpec.hs b/tests/Text/MMarkSpec.hs --- a/tests/Text/MMarkSpec.hs +++ b/tests/Text/MMarkSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,6 +9,7 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid import Data.Text (Text) +import Lucid import Test.Hspec import Test.Hspec.Megaparsec import Text.MMark (MMarkErr (..)) @@ -381,11 +383,10 @@ return () context "4.7 Link reference definitions" $ do it "CM159" $ - "[foo]: /url \"title\"\n\n[foo]" ==-> - "

foo

\n" + "[foo]: /url \"title\"\n\n[foo]" ##-> p_ (a_ [href_ "/url", title_ "title"] "foo") it "CM160" $ - " [foo]: \n /url \n 'the title' \n\n[foo]" ==-> - "

foo

\n" + " [foo]: \n /url \n 'the title' \n\n[foo]" ##-> + p_ (a_ [href_ "/url", title_ "the title"] "foo") it "CM161" $ let s = "[Foo bar\\]]:my_(url) 'title (with parens)'\n\n[Foo bar\\]]" in s ~~-> @@ -393,14 +394,14 @@ , errFancy 45 (couldNotMatchRef "Foo bar]" []) ] it "CM162" $ - "[Foo bar]:\n\n'title'\n\n[Foo bar]" ==-> - "

Foo bar

\n" + "[Foo bar]:\n\n'title'\n\n[Foo bar]" ##-> + p_ (a_ [href_ "my%20url", title_ "title"] "Foo bar") it "CM163" $ - "[foo]: /url '\ntitle\nline1\nline2\n'\n\n[foo]" ==-> - "

foo

\n" + "[foo]: /url '\ntitle\nline1\nline2\n'\n\n[foo]" ##-> + p_ (a_ [href_ "/url", title_ "\ntitle\nline1\nline2\n"] "foo") it "CM164" $ - "[foo]: /url 'title\n\nwith blank line'\n\n[foo]" ==-> - "

foo

\n" + "[foo]: /url 'title\n\nwith blank line'\n\n[foo]" ##-> + p_ (a_ [href_ "/url", title_ "title\n\nwith blank line"] "foo") it "CM165" $ "[foo]:\n/url\n\n[foo]" ==-> "

foo

\n" @@ -451,8 +452,13 @@ "# [Foo]\n[foo]: /url\n> bar" ==-> "

Foo

\n
\n

bar

\n
\n" it "CM180" $ - "[foo]: /foo-url \"foo\"\n[bar]: /bar-url\n \"bar\"\n[baz]: /baz-url\n\n[foo],\n[bar],\n[baz]" ==-> - "

foo,\nbar,\nbaz

\n" + "[foo]: /foo-url \"foo\"\n[bar]: /bar-url\n \"bar\"\n[baz]: /baz-url\n\n[foo],\n[bar],\n[baz]" ##-> + p_ (do + a_ [href_ "/foo-url", title_ "foo"] "foo" + ",\n" + a_ [href_ "/bar-url", title_ "bar"] "bar" + ",\n" + a_ [href_ "/baz-url"] "baz") it "CM181" $ "[foo]\n\n> [foo]: /url" ==-> "

foo

\n
\n
\n" @@ -868,11 +874,11 @@ "" ==-> "

<a href="\246\246.html">

\n" it "CM309" $ - "[foo](/föö \"föö\")" ==-> - "

foo

\n" + "[foo](/föö \"föö\")" ##-> + p_ (a_ [href_ "/föö",title_ "f\246\246"] "foo") it "CM310" $ - "[foo]\n\n[foo]: /föö \"föö\"" ==-> - "

foo

\n" + "[foo]\n\n[foo]: /föö \"föö\"" ##-> + p_ (a_ [href_ "/föö",title_ "f\246\246"] "foo") it "CM311" $ "``` föö\nfoo\n```" ==-> "
foo\n
\n" @@ -1290,8 +1296,8 @@ in s ~-> err 25 (ueib <> etoks "__" <> eic) context "6.5 Links" $ do it "CM459" $ - "[link](/uri \"title\")" ==-> - "

link

\n" + "[link](/uri \"title\")" ##-> + p_ (a_ [href_ "/uri",title_ "title"] "link") it "CM460" $ "[link](/uri)" ==-> "

link

\n" @@ -1350,11 +1356,17 @@ etok '?' <> elabel "ASCII alpha character" <> euri <> elabel "path piece" <> ews) it "CM476" $ - "[link](/url \"title\")\n[link](/url 'title')\n[link](/url (title))" ==-> - "

link\nlink\nlink

\n" + "[link](/url \"title\")\n[link](/url 'title')\n[link](/url (title))" ##-> + p_ (do + a_ [href_ "/url",title_ "title"] "link" + "\n" + a_ [href_ "/url",title_ "title"] "link" + "\n" + a_ [href_ "/url",title_ "title"] "link" + ) it "CM477" $ - "[link](/url \"title \\\""\")\n" ==-> - "

link

\n" + "[link](/url \"title \\\""\")\n" ##-> + p_ (a_ [href_ "/url",title_ "title \"\""] "link") it "CM478" $ let s = "[link](/url \"title\")" in s ~-> err 11 (utok ' ' <> euric <> euri) @@ -1362,11 +1374,11 @@ let s = "[link](/url \"title \"and\" title\")\n" in s ~-> err 20 (utok 'a' <> etok ')' <> ews) it "CM480" $ - "[link](/url 'title \"and\" title')" ==-> - "

link

\n" + "[link](/url 'title \"and\" title')" ##-> + p_ (a_ [href_ "/url",title_ "title \"and\" title"] "link") it "CM481" $ - "[link]( /uri\n \"title\" )" ==-> - "

link

\n" + "[link]( /uri\n \"title\" )" ##-> + p_ (a_ [href_ "/uri",title_ "title"] "link") it "CM482" $ let s = "[link] (/uri)\n" in s ~-> errFancy 1 (couldNotMatchRef "link" []) @@ -1416,8 +1428,8 @@ "[foo" ==-> "

foo<http://example.com/?search=>

\n" it "CM498" $ - "[foo][bar]\n\n[bar]: /url \"title\"" ==-> - "

foo

\n" + "[foo][bar]\n\n[bar]: /url \"title\"" ##-> + p_ (a_ [href_ "/url",title_ "title"] "foo") it "CM499" $ let s = "[link [foo [bar]]][ref]\n\n[ref]: /uri" in s ~-> err 6 (utok '[' <> etok ']' <> eic) @@ -1452,8 +1464,8 @@ "[foo\n\n[ref]: /uri" ==-> "

foo<http://example.com/?search=>

\n" it "CM510" $ - "[foo][BaR]\n\n[bar]: /url \"title\"" ==-> - "

foo

\n" + "[foo][BaR]\n\n[bar]: /url \"title\"" ##-> + p_ (a_ [href_ "/url",title_ "title"] "foo") it "CM511" $ "[Толпой][Толпой] is a Russian word.\n\n[ТОЛПОЙ]: /url" ==-> "

Толпой is a Russian word.

\n" @@ -1506,20 +1518,20 @@ [ errFancy 1 (couldNotMatchRef "" []) , errFancy 7 (couldNotMatchRef "" []) ] it "CM524" $ - "[foo][]\n\n[foo]: /url \"title\"" ==-> - "

foo

\n" + "[foo][]\n\n[foo]: /url \"title\"" ##-> + p_ (a_ [href_ "/url",title_ "title"] "foo") it "CM525" $ let s = "[*foo* bar][]\n\n[*foo* bar]: /url \"title\"" in s ~-> errFancy 1 (couldNotMatchRef "foo bar" ["*foo* bar"]) it "CM526" $ - "[Foo][]\n\n[foo]: /url \"title\"" ==-> - "

Foo

\n" + "[Foo][]\n\n[foo]: /url \"title\"" ##-> + p_ (a_ [href_ "/url",title_ "title"] "Foo") it "CM527" $ let s = "[foo] \n[]\n\n[foo]: /url \"title\"" in s ~-> err 8 (utok ']' <> eic) it "CM528" $ - "[foo]\n\n[foo]: /url \"title\"" ==-> - "

foo

\n" + "[foo]\n\n[foo]: /url \"title\"" ##-> + p_ (a_ [href_ "/url",title_ "title"] "foo") it "CM529" $ let s = "[*foo* bar]\n\n[*foo* bar]: /url \"title\"" in s ~-> errFancy 1 (couldNotMatchRef "foo bar" ["*foo* bar"]) @@ -1530,8 +1542,8 @@ let s = "[[bar [foo]\n\n[foo]: /url" in s ~-> err 1 (utok '[' <> eic) it "CM532" $ - "[Foo]\n\n[foo]: /url \"title\"" ==-> - "

Foo

\n" + "[Foo]\n\n[foo]: /url \"title\"" ##-> + p_ (a_ [href_ "/url", title_ "title"] "Foo") it "CM533" $ "[foo] bar\n\n[foo]: /url" ==-> "

foo bar

\n" @@ -1629,8 +1641,10 @@ "!\\[foo\\]\n\n[foo]: /url \"title\"" ==-> "

![foo]

\n" it "CM564" $ - "\\![foo]\n\n[foo]: /url \"title\"" ==-> - "

!foo

\n" + "\\![foo]\n\n[foo]: /url \"title\"" ##-> + p_ (do + "!" + a_ [href_ "/url",title_ "title"] "foo") context "6.7 Autolinks" $ do it "CM565" $ "" ==-> @@ -1966,15 +1980,20 @@ MMark.projectYaml doc `shouldBe` Nothing context "when document contains a YAML section" $ do context "when it is valid" $ do +#ifdef ghcjs_HOST_OS + let r = object [] +#else let r = object [ "x" .= Number 100 , "y" .= Number 200 ] +#endif it "returns the YAML section (1)" $ do doc <- mkDoc "---\nx: 100\ny: 200\n---\nHere we go." MMark.projectYaml doc `shouldBe` Just r it "returns the YAML section (2)" $ do doc <- mkDoc "---\nx: 100\ny: 200\n---\n\n" MMark.projectYaml doc `shouldBe` Just r +#ifndef ghcjs_HOST_OS context "when it is invalid" $ do let mappingErr = fancy . ErrorCustom . YamlParseError $ "mapping values are not allowed in this context" @@ -1987,6 +2006,7 @@ [ errFancy 15 mappingErr , err 33 (ueib <> etok '*' <> eic) ] +#endif ---------------------------------------------------------------------------- -- Testing extensions