diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Criterion.Main +import Text.Ogmarkup +import Data.Text (Text) +import Data.FileEmbed + +main = defaultMain [ bench "nf ogmarkup text -> text" $ nf (ogmarkup inputText) ConfText + , bench "whnf ogmarkup text -> text" $ whnf (ogmarkup inputText) ConfText + , bench "nf ogmarkup string -> string" $ nf (ogmarkup inputString) ConfString + , bench "whnf ogmarkup string -> string" $ whnf (ogmarkup inputString) ConfString + + ] + +inputString :: String +inputString = $(embedFile "bench/test.up") +inputText :: Text +inputText = $(embedFile "bench/test.up") + +data ConfText = ConfText +instance GenConf ConfText Text where + printSpace _ _ = " " + +data ConfString = ConfString +instance GenConf ConfString String where + printSpace _ _ = " " diff --git a/ogmarkup.cabal b/ogmarkup.cabal --- a/ogmarkup.cabal +++ b/ogmarkup.cabal @@ -1,5 +1,5 @@ name: ogmarkup -version: 3.0.0 +version: 3.0.1 cabal-version: >=1.10 build-type: Simple license: MIT @@ -13,6 +13,10 @@ category: Web author: Thomas Letan, Laurent Georget +flag bench + description: "a benchmark application" + default: False + source-repository head type: git location: https://github.com/ogma-project/ogmarkup @@ -46,6 +50,23 @@ default-language: Haskell2010 other-modules: ParserSpec, - GeneratorSpec + GeneratorSpec, + OgmarkupSpec hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N1 + +benchmark ogmarkup-bench + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Bench.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N1 + type: exitcode-stdio-1.0 + if flag(bench) + build-depends: base -any + , criterion -any + , ogmarkup -any + , file-embed-poly + , text -any + buildable: True + else + buildable: False diff --git a/src/Text/Ogmarkup.hs b/src/Text/Ogmarkup.hs --- a/src/Text/Ogmarkup.hs +++ b/src/Text/Ogmarkup.hs @@ -53,5 +53,18 @@ -> c -- ^ The generator configuration -> b ogmarkup input conf = case Parser.parse Parser.document "" input of - Right ast -> Gen.runGenerator (Gen.document ast) conf + Right ast -> Gen.runGenerator (Gen.document $ merge ast) conf Left _ -> error "failed to parse an ogmarkup document even with best effort" + where merge :: Ast.Document a -> Ast.Document a + merge ((Ast.Story x):rest) = (Ast.Story $ mergep x):rest + merge ((Ast.Aside cls x):rest) = (Ast.Aside cls (mergep x)):rest + merge (x:rest) = x:(merge rest) + merge [] = [] + + mergep :: [Ast.Paragraph a] -> [Ast.Paragraph a] + mergep (x@(_:_):y@((Ast.Dialogue _ _):_):rest) = + case last x of + Ast.Dialogue _ _ -> mergep $ (x `mappend` y):rest + _ -> x:(mergep $ y:rest) + mergep (x:y:rest) = x:(mergep $ y:rest) + mergep x = x diff --git a/src/Text/Ogmarkup/Private/Parser.hs b/src/Text/Ogmarkup/Private/Parser.hs --- a/src/Text/Ogmarkup/Private/Parser.hs +++ b/src/Text/Ogmarkup/Private/Parser.hs @@ -215,8 +215,8 @@ => OgmarkupParser a b characterName = do char '(' - notFollowedBy (char ')') "Empty character names are not allowed" - auth <- manyTill anyChar (char ')') "Missing closing )" + notFollowedBy (char ')') + auth <- manyTill anyChar (char ')') return $ fromString auth @@ -232,7 +232,7 @@ case x of '|' -> do blank ws <- some format - char '|' "Missing | to close the with say" + char '|' blank p2 <- many format char c' @@ -289,7 +289,7 @@ -- | See 'Ast.Atom'. atom :: (Stream a, Token a ~ Char, IsString b) => OgmarkupParser a (Ast.Atom b) -atom = (mark <|> longword <|> word) <* blank +atom = (word <|> mark <|> longword) <* blank -- | See 'Ast.Word'. This parser does not consume the following spaces, so -- the caller needs to take care of it. @@ -301,8 +301,8 @@ where endOfWord :: (Stream a, Token a ~ Char) => OgmarkupParser a () - endOfWord = eof <|> (skip spaceChar) <|> (skip $ oneOf specChar) <|> (skip mark) - specChar = "\"«»`+*[]<>|_\'’" + endOfWord = eof <|> (skip spaceChar) <|> (skip $ oneOf specChar) + specChar = "\"«»`+*[]<>|_\'’.,;-–—!?:" -- | Wrap a raw string surrounded by @`@ inside a 'Ast.Word'. @@ -315,7 +315,7 @@ longword :: (Stream a, Token a ~ Char, IsString b) => OgmarkupParser a (Ast.Atom b) longword = do char '`' - notFollowedBy (char '`') "empty raw string are not accepted" + notFollowedBy (char '`') str <- manyTill anyChar (char '`') return $ Ast.Word (fromString str) diff --git a/test/OgmarkupSpec.hs b/test/OgmarkupSpec.hs new file mode 100644 --- /dev/null +++ b/test/OgmarkupSpec.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module OgmarkupSpec where + +import Data.Text (Text) +import Test.Hspec +import Text.Shakespeare.Text + +import Text.Ogmarkup + +spec :: Spec +spec = do + describe "ogmarkup" $ do + it "should merge paragraphs with consecutive dialogues" $ + ogmarkup consecutiveDialogues TestConf `shouldBe` + "[doc][story][par][dial-anonymous]“[reply]This is a test.[/reply]”[/dial-anonymous][br][dial-anonymous]“[reply]May it works.[/reply]”[/dial-anonymous][/par][/story][/doc]" + it "should not merge other paragraphs" $ + ogmarkup notConsecutiveDialogues TestConf `shouldBe` + "[doc][story][par][dial-anonymous]“[reply]This is a test.[/reply]”[/dial-anonymous][/par][par]May it works.[/par][/story][/doc]" + + +consecutiveDialogues :: Text +consecutiveDialogues = "[This is a test.]\n\n[May it works.]" + +notConsecutiveDialogues :: Text +notConsecutiveDialogues = "[This is a test.]\n\nMay it works." + +data TestConf = TestConf + +instance GenConf TestConf Text where + typography _ = englishTypo + + documentTemplate _ doc = [st|[doc]#{doc}[/doc]|] + + errorTemplate _ err = [st|[error]#{err}[/error]|] + + storyTemplate _ story = [st|[story]#{story}[/story]|] + + asideTemplate _ (Just cls) aside = [st|[aside-#{cls}]#{aside}[/aside-#{cls}]|] + asideTemplate _ _ aside = [st|[aside]#{aside}[/aside]|] + + paragraphTemplate _ par = [st|[par]#{par}[/par]|] + + tellerTemplate _ teller = [st|[tell]#{teller}[/tell]|] + + dialogueTemplate _ auth dial = [st|[dial-#{auth}]#{dial}[/dial-#{auth}]|] + + thoughtTemplate _ auth thou = [st|[thou-#{auth}]#{thou}[/thou-#{auth}]|] + + replyTemplate _ rep = [st|[reply]#{rep}[/reply]|] + + betweenDialogue _ = "[br]" + + emphTemplate _ txt = [st|[em]#{txt}[/em]|] + + strongEmphTemplate _ txt = [st|[strong]#{txt}[/strong]|] + + authorNormalize _ = maybe "anonymous" id + + printSpace _ None = "" + printSpace _ Normal = " " + printSpace _ Nbsp = "_"