diff --git a/ogmarkup.cabal b/ogmarkup.cabal --- a/ogmarkup.cabal +++ b/ogmarkup.cabal @@ -1,10 +1,10 @@ name: ogmarkup -version: 4.0 +version: 5.0 cabal-version: >=1.10 build-type: Simple license: MIT license-file: LICENSE -copyright: 2016 - 2017 Ogma Project +copyright: 2016 - 2018 Ogma Project maintainer: contact@thomasletan.fr homepage: https://nest.pijul.com/lthms/ogmarkup synopsis: A lightweight markup language for story writers diff --git a/src/Text/Ogmarkup.hs b/src/Text/Ogmarkup.hs --- a/src/Text/Ogmarkup.hs +++ b/src/Text/Ogmarkup.hs @@ -32,7 +32,11 @@ -- * Typography Typo.frenchTypo, + Typo.unicodeFrenchTypo, + Typo.htmlFrenchTypo, Typo.englishTypo, + Typo.unicodeEnglishTypo, + Typo.htmlEnglishTypo, Typo.Typography (..), -- * Punctuation marks and space diff --git a/src/Text/Ogmarkup/Private/Ast.hs b/src/Text/Ogmarkup/Private/Ast.hs --- a/src/Text/Ogmarkup/Private/Ast.hs +++ b/src/Text/Ogmarkup/Private/Ast.hs @@ -88,4 +88,6 @@ | Hyphen -- ^ The character @-@ | SuspensionPoints -- ^ Two or more @.@ or the character … | Apostrophe -- ^ The characters @'@ or @’@ + | Interrobang -- ^ The strange character @‽@, obtained @?!@ or @?!@ + | Irony -- ^ The character @؟@, obtained with @??@ deriving (Show, Eq) diff --git a/src/Text/Ogmarkup/Private/Config.hs b/src/Text/Ogmarkup/Private/Config.hs --- a/src/Text/Ogmarkup/Private/Config.hs +++ b/src/Text/Ogmarkup/Private/Config.hs @@ -46,7 +46,7 @@ -- -- * __Default implementation:__ returns 'englishTypo'. typography :: Typography o - typography = englishTypo + typography = unicodeEnglishTypo -- | This template is used once the output has been completely generated. -- 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 @@ -360,6 +360,8 @@ => OgmarkupParser a (Ast.Atom b) mark = Ast.Punctuation `fmap` (semicolon <|> colon + <|> try interrobang + <|> try irony <|> question <|> exclamation <|> try longDash @@ -372,6 +374,8 @@ where parseMark p m = p >> return m + irony = parseMark (char '?' >> char '?') Ast.Irony + interrobang = parseMark ((char '?' >> char '!') <|> (char '!' >> char '?')) Ast.Interrobang semicolon = parseMark (char ';') Ast.Semicolon colon = parseMark (char ':') Ast.Colon question = parseMark (char '?') Ast.Question diff --git a/src/Text/Ogmarkup/Private/Typography.hs b/src/Text/Ogmarkup/Private/Typography.hs --- a/src/Text/Ogmarkup/Private/Typography.hs +++ b/src/Text/Ogmarkup/Private/Typography.hs @@ -8,6 +8,7 @@ for French and English. -} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Text.Ogmarkup.Private.Typography where @@ -32,35 +33,36 @@ -- | A Typography is a data type that tells the caller what space -- should be privileged before and after a text. data Typography a = Typography { - decide :: Ast.Mark -> (Space, Space, a), -- ^ For a given 'Ast.Mark', - -- returns a tuple with the - -- spaces to use before - -- and after the - -- punctuation mark and - -- its output value. - openDialogue :: Bool -> Maybe Ast.Mark, -- ^ Which mark to use to - -- open a dialogue. If - -- the parameter is True, - -- there were another - -- dialogue just before. - closeDialogue :: Bool -> Maybe Ast.Mark -- ^ Which mark to use to - -- close a dialogue. If - -- the parameter is True, - -- there is another - -- dialogue just after. + decide :: Ast.Mark -> (Space, Space) -- ^ For a given 'Ast.Mark', + -- returns a tuple with the + -- spaces to use before + -- and after the + -- punctuation mark. + , output :: Ast.Mark -> a -- ^ Give an output + -- representation of the + -- punctuation mark + , openDialogue :: Bool -> Maybe Ast.Mark -- ^ Which mark to use to + -- open a dialogue. If + -- the parameter is True, + -- there were another + -- dialogue just before. + , closeDialogue :: Bool -> Maybe Ast.Mark -- ^ Which mark to use to + -- close a dialogue. If + -- the parameter is True, + -- there is another + -- dialogue just after. } -- | Apply the function to each 'Ast.Mark' output value instance Functor Typography where - f `fmap` (Typography d o c) = let d' m = let (s1, s2, x) = d m in (s1, s2, f x) - in Typography d' o c + f `fmap` (Typography d op o c) = Typography d (f . op) o c -- | From a Typography, it gives the space to privilege before the -- input Text. beforeAtom :: Typography a -> Ast.Atom a -> Space -beforeAtom t (Ast.Punctuation m) = case decide t m of (r, _, _) -> r +beforeAtom t (Ast.Punctuation m) = case decide t m of (r, _) -> r beforeAtom t _ = Normal -- | From a Typography, it gives the space to privilege after the @@ -68,14 +70,14 @@ afterAtom :: Typography a -> Ast.Atom a -> Space -afterAtom t (Ast.Punctuation m) = case decide t m of (_, r, _) -> r +afterAtom t (Ast.Punctuation m) = case decide t m of (_, r) -> r afterAtom t _ = Normal -- | Normalize the input in order to add it to a generated Text. normalizeAtom :: Typography a -> Ast.Atom a -> a -normalizeAtom t (Ast.Punctuation m) = case decide t m of (_, _, r) -> r +normalizeAtom t (Ast.Punctuation m) = output t m normalizeAtom t (Ast.Word w) = w -- * Ready-to-use Typography @@ -83,23 +85,25 @@ -- | A proposal for the French typography. It can be used with several generation -- approaches, as it remains very generic. Requires the output type to be an -- instance of 'IsString'. -frenchTypo :: IsString a => Typography a -frenchTypo = Typography t prevT nextT +frenchTypo :: (Ast.Mark -> a) -> Typography a +frenchTypo op = Typography t op prevT nextT where - t :: IsString a => Ast.Mark -> (Space, Space, a) - t Ast.Semicolon = (Nbsp, Normal, ";") - t Ast.Colon = (Nbsp, Normal, ":") - t Ast.OpenQuote = (Normal, Nbsp, "«") - t Ast.CloseQuote = (Nbsp, Normal, "»") - t Ast.Question = (Nbsp, Normal, "?") - t Ast.Exclamation = (Nbsp, Normal, "!") - t Ast.LongDash = (Normal, Normal, "—") - t Ast.Dash = (None, None, "–") - t Ast.Hyphen = (None, None, "-") - t Ast.Comma = (None, Normal, ",") - t Ast.Point = (None, Normal, ".") - t Ast.Apostrophe = (None, None, "’") - t Ast.SuspensionPoints = (None, Normal, "…") + t :: Ast.Mark -> (Space, Space) + t Ast.Semicolon = (Nbsp, Normal) + t Ast.Colon = (Nbsp, Normal) + t Ast.OpenQuote = (Normal, Nbsp) + t Ast.CloseQuote = (Nbsp, Normal) + t Ast.Irony = (Nbsp, Normal) + t Ast.Interrobang = (Nbsp, Normal) + t Ast.Question = (Nbsp, Normal) + t Ast.Exclamation = (Nbsp, Normal) + t Ast.LongDash = (Normal, Normal) + t Ast.Dash = (None, None) + t Ast.Hyphen = (None, None) + t Ast.Comma = (None, Normal) + t Ast.Point = (None, Normal) + t Ast.Apostrophe = (None, None) + t Ast.SuspensionPoints = (None, Normal) prevT True = Just Ast.LongDash prevT False = Just Ast.OpenQuote @@ -107,23 +111,97 @@ nextT True = Nothing nextT False = Just Ast.CloseQuote +unicodeFrenchTypo :: (IsString a) => Typography a +unicodeFrenchTypo = frenchTypo $ \case + Ast.Semicolon -> ";" + Ast.Colon -> "," + Ast.OpenQuote -> "«" + Ast.CloseQuote -> "»" + Ast.Irony -> "⸮" + Ast.Interrobang -> "‽" + Ast.Question -> "?" + Ast.Exclamation -> "!" + Ast.LongDash -> "—" + Ast.Dash -> "–" + Ast.Hyphen -> "-" + Ast.Comma -> "," + Ast.Point -> "." + Ast.Apostrophe -> "’" + Ast.SuspensionPoints -> "…" + +htmlFrenchTypo :: (IsString a) => Typography a +htmlFrenchTypo = frenchTypo $ \case + Ast.Semicolon -> ";" + Ast.Colon -> "," + Ast.OpenQuote -> "«" + Ast.CloseQuote -> "»" + Ast.Irony -> "⸮" + Ast.Interrobang -> "‽" + Ast.Question -> "?" + Ast.Exclamation -> "!" + Ast.LongDash -> "—" + Ast.Dash -> "–" + Ast.Hyphen -> "-" + Ast.Comma -> "," + Ast.Point -> "." + Ast.Apostrophe -> "’" + Ast.SuspensionPoints -> "…" + -- | A proposal for the English typography. It can be used with several generation -- approaches, as it remains very generic. Requires the output type to be an -- instance of 'IsString'. -englishTypo :: IsString a => Typography a -englishTypo = Typography t (pure $ Just Ast.OpenQuote) (pure $ Just Ast.CloseQuote) +englishTypo :: (Ast.Mark -> a) -> Typography a +englishTypo op = Typography t op (pure $ Just Ast.OpenQuote) (pure $ Just Ast.CloseQuote) where - t :: IsString a => Ast.Mark -> (Space, Space, a) - t Ast.Semicolon = (None, Normal, ";") - t Ast.Colon = (None, Normal, ":") - t Ast.OpenQuote = (Normal, None, "“") - t Ast.CloseQuote = (None, Normal, "”") - t Ast.Question = (None, Normal, "?") - t Ast.Exclamation = (None, Normal, "!") - t Ast.LongDash = (Normal, None, "—") - t Ast.Dash = (None, None, "–") - t Ast.Hyphen = (None, None, "-") - t Ast.Comma = (None, Normal, ",") - t Ast.Point = (None, Normal, ".") - t Ast.Apostrophe = (None, None, "'") - t Ast.SuspensionPoints = (None, Normal, "…") + t :: Ast.Mark -> (Space, Space) + t Ast.Semicolon = (None, Normal) + t Ast.Colon = (None, Normal) + t Ast.OpenQuote = (Normal, None) + t Ast.CloseQuote = (None, Normal) + t Ast.Irony = (None, Normal) + t Ast.Interrobang = (None, Normal) + t Ast.Question = (None, Normal) + t Ast.Exclamation = (None, Normal) + t Ast.LongDash = (Normal, None) + t Ast.Dash = (None, None) + t Ast.Hyphen = (None, None) + t Ast.Comma = (None, Normal) + t Ast.Point = (None, Normal) + t Ast.Apostrophe = (None, None) + t Ast.SuspensionPoints = (None, Normal) + +unicodeEnglishTypo :: (IsString a) => Typography a +unicodeEnglishTypo = englishTypo $ \case + Ast.Semicolon -> ";" + Ast.Colon -> "," + Ast.OpenQuote -> "“" + Ast.CloseQuote -> "”" + Ast.Irony -> "⸮" + Ast.Interrobang -> "‽" + Ast.Question -> "?" + Ast.Exclamation -> "!" + Ast.LongDash -> "—" + Ast.Dash -> "–" + Ast.Hyphen -> "-" + Ast.Comma -> "," + Ast.Point -> "." + Ast.Apostrophe -> "’" + Ast.SuspensionPoints -> "…" + +htmlEnglishTypo :: (IsString a) => Typography a +htmlEnglishTypo = englishTypo $ \case + Ast.Semicolon -> ";" + Ast.Colon -> "," + Ast.OpenQuote -> "“" + Ast.CloseQuote -> "”" + Ast.Irony -> "⸮" + Ast.Interrobang -> "‽" + Ast.Question -> "?" + Ast.Exclamation -> "!" + Ast.LongDash -> "—" + Ast.Dash -> "–" + Ast.Hyphen -> "-" + Ast.Comma -> "," + Ast.Point -> "." + Ast.Apostrophe -> "’" + Ast.SuspensionPoints -> "…" diff --git a/test/GeneratorSpec.hs b/test/GeneratorSpec.hs --- a/test/GeneratorSpec.hs +++ b/test/GeneratorSpec.hs @@ -32,7 +32,7 @@ data TestConf instance GenConf TestConf Text where - typography = frenchTypo + typography = unicodeFrenchTypo documentTemplate doc = [st|[doc]#{doc}[/doc]|] diff --git a/test/OgmarkupSpec.hs b/test/OgmarkupSpec.hs --- a/test/OgmarkupSpec.hs +++ b/test/OgmarkupSpec.hs @@ -33,7 +33,7 @@ data TestConf instance GenConf TestConf Text where - typography = englishTypo + typography = unicodeEnglishTypo documentTemplate doc = [st|[doc]#{doc}[/doc]|] diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -29,6 +29,9 @@ it "should parse one punctuation mark" $ parse' Parser.atom "" exclamationStr `shouldParse` exclamationAtom + it "should parse exotic punctuation marks" $ + parse' Parser.atom "" "??" `shouldParse` Ast.Punctuation Ast.Irony + describe "format" $ do it "should parse one quote" $ parse' Parser.format "" quoteStr `shouldParse` quoteFormat