packages feed

ogmarkup (empty) → 2.1

raw patch · 11 files changed

+1305/−0 lines, 11 filesdep +basedep +blaze-htmldep +hspecsetup-changed

Dependencies added: base, blaze-html, hspec, mtl, ogmarkup, parsec, shakespeare, text, yesod

Files

+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Iky++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import           Text.Ogmarkup++import           Data.Text                     (Text)+import qualified Data.Text.IO                  as TIO+import           System.IO+import           Text.ParserCombinators.Parsec+import           Text.Shakespeare.Text+import Text.Hamlet+import Text.Blaze.Html.Renderer.String (renderHtml)+import Text.Blaze.Html (preEscapedToHtml)++main :: IO ()+main = do+  input <- readFile "examples/sample.up"+  let res = ogmarkup ByLine input HtmlConf+      res' = ogmarkup ByChar input HtmlConf++  putStrLn $ renderHtml [shamlet|$doctype 5+<html>+  <head>+    <meta charset=utf-8>+    <style>+      body {+        margin:auto;+        width: 80%;+        max-width: 600px;+        text-align: justify;+      }+      p {+        text-indent:25px;+      }+      .error {+        color: red;+        background-color: black;+      }+      .reply {+        color:gray;+      }+      .dialogue .by-kahina .reply {+        font-weight: bold;+      }+      .thought .reply {+        font-style: italic;+      }+  <body>+    <div>+      #{res}+    <div>+      #{res'}|]++data HtmlConf = HtmlConf++instance GenConf HtmlConf Html where+  typography _ = frenchTypo++  documentTemplate _ doc = [shamlet|<article>#{doc}|]++  asideTemplate _ (Just cls) a = [shamlet|<blockquote .#{cls}>#{a}|]+  asideTemplate _ _ a = [shamlet|<blockquote>#{a}|]++  paragraphTemplate _ paragraph = [shamlet|<p>#{paragraph}|]++  dialogueTemplate _ a dialogue = [shamlet|$newline never+                                           <span .dialogue .#{a}>#{dialogue}|]++  thoughtTemplate _ a thought = [shamlet|$newline never+                                         <span .thought .by-#{a}>#{thought}|]++  replyTemplate _ reply = [shamlet|$newline never+                                   <span .reply>#{reply}|]++  betweenDialogue _ = preEscapedToHtml ("</p><p>" :: Text)++  emphTemplate _ text = [shamlet|$newline never+                                 <em>#{text}|]+  strongEmphTemplate _ text = [shamlet|$newline never+                                       <strong>#{text}|]++  authorNormalize _ Nothing = "by-anonymus"+  authorNormalize _ (Just auth) = [shamlet|by-#{auth}|]++  printSpace _ None = ""+  printSpace _ Normal = " "+  printSpace _ Nbsp = [shamlet|&nbsp;|]
+ ogmarkup.cabal view
@@ -0,0 +1,60 @@+name: ogmarkup+version: 2.1+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE+copyright: 2016 Ogma Project+maintainer: contact@thomasletan.fr+homepage: http://github.com/ogma-project/ogmarkup+synopsis: A lightweight markup language for story writers+description:+    Please see README.md+category: Web+author: Thomas Letan, Laurent Georget++source-repository head+    type: git+    location: https://github.com/ogma-project/ogmarkup++library+    exposed-modules:+        Text.Ogmarkup+        Text.Ogmarkup.Private.Parser+        Text.Ogmarkup.Private.Ast+        Text.Ogmarkup.Private.Generator+        Text.Ogmarkup.Private.Typography+        Text.Ogmarkup.Private.Config+    build-depends:+        base >=4.7 && <5,+        parsec ==3.1.*,+        mtl -any+    default-language: Haskell2010+    hs-source-dirs: src++executable ogmarkup+    main-is: Main.hs+    build-depends:+        base -any,+        ogmarkup -any,+        parsec -any,+        text -any,+        yesod -any,+        shakespeare -any,+        blaze-html -any+    default-language: Haskell2010+    hs-source-dirs: app++test-suite ogmadown-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    build-depends:+        base -any,+        hspec -any,+        ogmarkup -any,+        parsec -any,+        shakespeare -any,+        text -any+    default-language: Haskell2010+    hs-source-dirs: test+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
+ src/Text/Ogmarkup.hs view
@@ -0,0 +1,92 @@+{-|+Module      : Text.Ogmarkup+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++The ogmarkup library provides an ogmarkup document compiler. This module is the+only one you should need to import in your project.++The library is still in an early stage of development, hence the "experimental"+stability. Be aware the exposed interface may change in future realase.+-}++module Text.Ogmarkup+    (+      -- * Parse and Generate+      Strategy (..),+      ogmarkup,++      -- * Generation Configuration+      Conf.GenConf (..),+      Conf.Template,++      -- * Typography+      Typo.frenchTypo,+      Typo.englishTypo,+      Typo.Typography (..),++      -- * Punctuation marks and space+      Ast.Mark (..),+      Typo.Space (..),+    ) where++import           Data.String+import           Data.List+import           Text.ParserCombinators.Parsec+import           Data.Monoid++import qualified Text.Ogmarkup.Private.Config     as Conf+import qualified Text.Ogmarkup.Private.Ast        as Ast+import qualified Text.Ogmarkup.Private.Generator  as Gen+import qualified Text.Ogmarkup.Private.Parser     as Parser+import qualified Text.Ogmarkup.Private.Typography as Typo++-- | With the best-effort compilation feature of ogmarkup, when the parser+--   encounters an error, it can apply two different strategies with the+--   remaining input to find a new synchronization point. It can search+--   character by character or line by line.+data Strategy =+    ByLine+  | ByChar++-- | From a String, parse and generate an output according to a generation configuration.+--   The inner definitions of the parser and the generator imply that the output+--   type has to be an instance of the 'IsString' and 'Monoid' classes.+ogmarkup :: (IsString a, Monoid a, Conf.GenConf c a)+         => Strategy       -- ^ Best-effort compilation strategy+         -> String         -- ^ The input string+         -> c              -- ^ The generator configuration+         -> a+ogmarkup be input conf = Gen.runGenerator (Gen.document (_ogmarkup be "" input [])) conf+  where+    _ogmarkup :: (IsString a, Monoid a)+              => Strategy -- best-effort compilation strategy+              -> String   -- acc+              -> String   -- input+              -> Ast.Document a+              -> Ast.Document a++    _ogmarkup _ "" "" ast = ast++    _ogmarkup _ acc "" ast = ast `mappend` [Ast.Failing . fromString $ acc]++    _ogmarkup be acc input ast =+      case Parser.parse Parser.document "" input of+        Right (ast', input') ->+          if input == input'  -- nothing has been parsed+          then let (c, rst) = applyStrat be input+               in _ogmarkup be (acc `mappend` c) rst ast+          else if acc == ""+               then _ogmarkup be [] input' (ast `mappend` ast')+               else let f = Ast.Failing . fromString $ acc+                    in _ogmarkup be [] input' (ast `mappend` (f:ast'))+        Left err -> error $ show err++    applyStrat :: Strategy+               -> String+               -> (String, String)++    applyStrat _ [] = ([], [])+    applyStrat ByLine input = break (== '\n') input+    applyStrat ByChar (c:rst) = ([c], rst)
+ src/Text/Ogmarkup/Private/Ast.hs view
@@ -0,0 +1,91 @@+{-|+Module      : Text.Ogmarkup.Private.Ast+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++An abstract representation of an ogmarkup document.+-}++module Text.Ogmarkup.Private.Ast where++-- | A ogmarkup document internal representation waiting to be used in order+--   to generate an output.+type Document a = [Section a]++-- | A Section within an ogmarkup document is a sequence of paragraphs. It+-- can be part of the story or an aside section like a letter, a song, etc.+-- We make the distinction between the two cases because we want to be able+-- to apply different style depending on the situation.+data Section a =+    Story [Paragraph a]           -- ^ The story as it goes+  | Aside (Maybe a) [Paragraph a] -- ^ Something else. Maybe a letter, a flashback, etc.+  | Failing a+    deriving (Eq,Show)++-- | A Paragraph is just a sequence of Component.+type Paragraph a = [Component a]++-- | A Component is either a narrative text, a character's line of dialogue or+-- a character's inner thought.+--+-- We also embed an error Component in case we fail to parse a valid+-- component. This way, we can resume parsing when we meet a new paragraph.+data Component a =+    Teller [Format a]            -- ^ A narrative description+  | Dialogue (Reply a) (Maybe a) -- ^ A dialogue reply+  | Thought (Reply a) (Maybe a)  -- ^ Inner dialogue of the character+  | IllFormed a                  -- ^ If none of the above matched, then output+                                 --   what follows as-is, the parsing will+                                 --   be resumed at the next paragraph+    deriving (Eq,Show)++-- | A character's line of dialogue. A reply may contain a descriptive part, which+--   is not part of what the character actually says or thinks. We call the+--   latter a "with say" reply untill someone gives use a better name for it.+data Reply a =+  -- | A reply of the form: "Good morning."+  Simple [Format a]+  -- | A reply of the form: "Good morning," she says. "How are you?"+  | WithSay [Format a] [Format a] [Format a]+    deriving (Eq,Show)++-- | A nested formatted text+data Format a =+  Raw [Atom a]                -- ^ No particular emphasis is required on this sequence+  | Emph [Format a]           -- ^ Surrounded by @*@.+  | StrongEmph [Format a]     -- ^ Surrounded by @**@.+  | Quote [Format a]+    deriving (Show,Eq)++-- | An Atom is the atomic component of a Ogmarkup document. It can be either a+--   punctuation mark or a word, that is a string.+--+--   Note that, by construction, 'OpenQuote' and 'CloseQuote' are not valid+--   'Mark' values here.  Indeed, they are implicit with the 'Quote'+--   constructor. This design allows the parser to enforce that an opened quote+--   needs to be closed.+data Atom a =+    Word a           -- ^ A wrapped string+  | Punctuation Mark -- ^ A punctuation mark+    deriving (Show,Eq)+++-- | Mostly in order to deal with typographic spaces, main+--   punctuation marks are tokenized during the parsing of an+--   Ogmarkup document.+data Mark =+    Semicolon        -- ^ The character @;@+  | Colon            -- ^ The character @,@+  | Question         -- ^ The character @?@+  | Exclamation      -- ^ The character @!@+  | OpenQuote        -- ^ The character @"@+  | CloseQuote       -- ^ The character @"@+  | Dash             -- ^ The character – or the sequence @--@+  | LongDash         -- ^ The character — or the sequence @---@+  | Comma            -- ^ The character @,@+  | Point            -- ^ The character @.@+  | Hyphen           -- ^ The character @-@+  | SuspensionPoints -- ^ Two or more @.@ or the character …+  | Apostrophe       -- ^ The characters @'@ or @’@+    deriving (Show, Eq)
+ src/Text/Ogmarkup/Private/Config.hs view
@@ -0,0 +1,174 @@+{-|+Module      : Text.Ogmarkup.Private.Config+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++This module provides the 'GenConf' typeclass which is used to configure the+'Text.Ogmarkup.Private.Generator's monad.+-}++{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE FunctionalDependencies #-}++module Text.Ogmarkup.Private.Config where++import           Data.Monoid+import           Data.String+import           Data.Maybe+import           Text.Ogmarkup.Private.Typography++-- | A 'Template' is just synonym for a template of one argument.+type Template a = a -> a++-- | An instance of the 'GenConf' typeclass can be given as a parameter to+-- a 'Text.Ogmarkup.Private.Generator.Generator'.  In order to prevent GHC+-- to overabstract this typeclass, there can be only one instance of+-- GenConf for one datatype. In other words, one datatype can only handle+-- one return type @c@.+--+-- For each template, we give a prefered layout and some hints about the+-- default implementation (which is almost always the identity function,+-- ignoring all the parameters but the generated output.+--+-- __Warning:__ 'GenConf' is a multiparam typeclass (see+-- @MultiParamTypeClasses@ GHC extension). In order to make new instances,+-- the following extensions need to be enabled:+--+--     * @FlexibleInstances@+--     * @MultiParamTypeClasses@+--+-- Otherwise, GHC will not accept your instance statement.+class (IsString o, Monoid o) => GenConf c o | c -> o where+  -- | Returns a 'Typography' instance to be used by the+  -- 'Text.Ogmarkup.Private.Generator.Generator'.+  --+  --     * __Default implementation:__ returns 'englishTypo'.+  typography :: c+             -> Typography o+  typography _ = englishTypo++  -- | This template is used once the output has been completely generated.+  --+  --     * __Layout:__ block +  --     * __Default implementation:__ the identity function+  documentTemplate :: c+                   -> Template o+  documentTemplate _ = id++  -- | This template is used on the ill-formed portion of the ogmarkup+  -- document which have been ignored during the best-effort compilation.+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ the identity function+  errorTemplate :: c+                -> Template o+  errorTemplate _ = id++  -- | This template is used on regular sections which focus on telling the+  -- story.+  --+  --     * __Layout:__ block+  --     * __Default implementation:__ the identity function+  storyTemplate :: c+                -> Template o+  storyTemplate _ = id++  -- | This template is used on aside sections which may comprised+  -- flashbacks, letters or songs, for instance.+  --+  --     * __Layout:__ block+  --     * __Default implementation:__ the identity function (it ignores the+  --       class name)+  asideTemplate :: c+                -> Maybe o      -- ^ An optional class name+                -> Template o+  asideTemplate _ _ = id++  -- | This template is used on paragraphs within a section.+  --+  --     * __Layout:__ block+  --     * __Default implementation:__ the identity function+  paragraphTemplate :: c+                    -> Template o+  paragraphTemplate _ = id++  -- | This template is used on the narrative portion of an ogmarkup+  -- document.+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ the identity function+  tellerTemplate :: c+                 -> Template o+  tellerTemplate _ = id++  -- | This template is used on audible dialogue. The class name is+  -- mandatory even if the character name is optional for dialogues and+  -- thoughts in the ogmarkup grammar.  The `authorNormalize` function is+  -- used by the generator to get a default value when no character names+  -- are provided.+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ the identity function+  dialogueTemplate :: c+                   -> o            -- ^ The class name produced by 'authorNormalize'+                   -> Template o+  dialogueTemplate _ _ = id++  -- | This template is used on unaudible dialogue. See 'dialogueTemplate' to+  -- get more information on why the class name is not+  -- optional.+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ the identity function+  thoughtTemplate :: c+                   -> o            -- ^ The class name produced by 'authorNormalize'+                  -> Template o+  thoughtTemplate _ _ = id++  -- __Default implementation:__ the identity function+  replyTemplate :: c+                -> Template o+  replyTemplate _ = id++  -- | Return a marker to insert between two consecutive dialogues. The+  -- default use case is to return the concatenation of the ending mark and+  -- the opening mark of a paragraph.+  -- a paragrap+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ `mempty`+  betweenDialogue :: c+                  -> o+  betweenDialogue _ = mempty++  -- | A template to apply emphasis to an piece of text.+  --+  -- __Default implementation:__ the identity function+  emphTemplate :: c+               -> Template o+  emphTemplate _ = id++  -- | A template to apply stong emphasis (often bold) to a piece of text.+  --+  --     * __Layout:__ inline+  --     * __Default implementation:__ `mempty`+  strongEmphTemplate :: c+                     -> Template o+  strongEmphTemplate _ = id++  -- | This function is called by a Generator to derive a class name for an+  -- optional character name.+  --+  --     * __Default implementation:__ simply unwrap the Maybe value, if+  --     Nothing return 'mempty'.+  authorNormalize :: c+                  -> Maybe o+                  -> o+  authorNormalize _ = maybe mempty id++  -- | Generate an output from a 'Space'.+  printSpace :: c+             -> Space+             -> o
+ src/Text/Ogmarkup/Private/Generator.hs view
@@ -0,0 +1,270 @@+{-|+Module      : Text.Ogmarkup.Private.Generator+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++The generation of the output from an 'Ast.Ast' is carried out by the 'Generator'+Monad.++-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++module Text.Ogmarkup.Private.Generator where++import           Control.Monad.Reader+import           Control.Monad.State.Strict+import           Data.Monoid++import qualified Text.Ogmarkup.Private.Ast        as Ast+import           Text.Ogmarkup.Private.Config     as Conf+import           Text.Ogmarkup.Private.Typography++-- * The 'Generator' Monad++-- | The 'Generator' Monad is eventually used to generate an output from a+--   given 'Ast.Document. Internally, it keeps track of the previous processed+--   'Ast.Atom' in order to deal with atom separation.+newtype Generator c a x = Generator { getState :: StateT (a, Maybe (Ast.Atom a)) (Reader c) x }+  deriving (Functor, Applicative, Monad, MonadState (a, Maybe (Ast.Atom a)), MonadReader c)++-- | Run a 'Generator' monad and get the generated output. The output+--   type has to implement the class 'Monoid' because the 'Generator' monad+--   uses the 'mempty' constant as the initial state of the output and then+--   uses 'mappend' to expand the result as it processes the generation.+runGenerator :: Monoid a+             => Generator c a x -- ^ The 'Generator' to run+             -> c               -- ^ The configuration to use during the generation+             -> a              -- ^ The output+runGenerator gen conf = fst $ runReader (execStateT (getState gen) (mempty, Nothing)) conf++-- * Low-level 'Generator's++-- | Retrieve a configuration parameter. Let the output untouched.+askConf :: (c -> b) -- ^ The function to apply to the 'GenConf' variable+                    --   to retreive the wanted parameter+        -> Generator c a b+askConf f = f <$> ask++-- | Apply a template to the result of a given 'Generator' before appending it+--   to the previously generated output.+apply :: Monoid a+      => Template a      -- ^ The 'Template' to apply+      -> Generator c a x   -- ^ The 'Generator' to run+      -> Generator c a ()+apply app gen = do+  (str, maybe) <- get+  put (mempty, maybe)+  gen+  (str', maybe') <- get+  put (str `mappend` app str', maybe')++-- | Forget about the past and consider the next 'Ast.Atom' as the+--   first to be processed.+reset :: Generator c a ()+reset = do+  (str, _) <- get+  put (str, Nothing)++-- | Append a new sub-output to the generated output.+raw :: Monoid a+    => a                -- ^ A sub-output to append+    -> Generator c a ()+raw str' = do+  (str, maybePrev) <- get+  put (str `mappend` str', maybePrev)++-- * AST Processing 'Generator's++-- | Process an 'Ast.Atom' and deal with the space to use to separate it from+--   the paramter of the previous call (that is the last processed+--   'Ast.Atom').+atom :: (Monoid a, GenConf c a)+     => Ast.Atom a+     -> Generator c a ()+atom text = do+  (str, maybePrev) <- get+  typo <- askConf typography+  ptrSpace <- askConf printSpace++  case maybePrev of+    Just prev ->+      let+        spc =  (ptrSpace $ max (afterAtom typo prev) (beforeAtom typo text))+        str' = spc `mappend` normalizeAtom typo text+      in+        put (str `mappend` str', Just text)+    Nothing -> put (str `mappend` normalizeAtom typo text, Just text)++-- | Call 'atom' if the parameter is not 'Nothing'. Otherwise, do nothing.+maybeAtom :: (Monoid a, GenConf c a)+          => Maybe (Ast.Atom a)+          -> Generator c a ()+maybeAtom (Just text) = atom text+maybeAtom Nothing = return ()++-- | Process a sequence of 'Ast.Atom'.+atoms :: (Monoid a, GenConf c a)+      => [Ast.Atom a]+      -> Generator c a ()+atoms (f:rst) = do+  atom f+  atoms rst+atoms [] = return ()++-- | Process a 'Ast.Format'.+format :: (Monoid a, GenConf c a)+       => Ast.Format a+       -> Generator c a ()++format (Ast.Raw as) = atoms as++format (Ast.Emph fs) = do+  temp <- askConf emphTemplate++  apply temp (formats fs)++format (Ast.StrongEmph fs) = do+  temp <- askConf strongEmphTemplate++  apply temp (formats fs)++format (Ast.Quote fs) = do+  atom $ Ast.Punctuation Ast.OpenQuote+  formats fs+  atom $ Ast.Punctuation Ast.CloseQuote++-- | Process a sequence of 'Ast.Format'.+formats :: (Monoid a, GenConf c a)+           => [Ast.Format a]+           -> Generator c a ()+formats (f:rst) = do+  format f+  formats rst+formats [] = return ()++-- | Process a 'Ast.Reply'.+reply :: (Monoid a, GenConf c a)+      => Maybe (Ast.Atom a)+      -> Maybe (Ast.Atom a)+      -> Ast.Reply a+      -> Generator c a ()+reply begin end (Ast.Simple d) = do+  temp <- askConf replyTemplate++  maybeAtom begin+  apply temp (formats d)+  maybeAtom end+reply begin end (Ast.WithSay d ws d') = do+  temp <- askConf replyTemplate++  maybeAtom begin+  apply temp (formats d)++  case d' of [] -> do+               maybeAtom end+               formats ws+             l -> do+               formats ws+               apply temp (formats d')+               maybeAtom end++-- | Process a 'Ast.Component'.+component :: (Monoid a, GenConf c a)+          => Bool           -- ^ Was the last component a piece of dialog?+          -> Bool           -- ^ Will the next component be a piece of dialog?+          -> Ast.Component a  -- ^ The current component to process+          -> Generator c a ()+component p n (Ast.Dialogue d a) = do+  typo <- askConf typography+  auth <- askConf authorNormalize+  temp <- askConf dialogueTemplate++  let+    open = openDialogue typo+    close = closeDialogue typo++  apply (temp $ auth a) (reply (Ast.Punctuation <$> open p) (Ast.Punctuation <$> close n) d)++component p n (Ast.Thought d a) = do+  auth <- askConf authorNormalize+  temp <- askConf thoughtTemplate++  apply (temp $ auth a) (reply Nothing Nothing d)+component p n (Ast.Teller fs) = formats fs+component p n (Ast.IllFormed ws) = do+    temp <- askConf errorTemplate+    apply temp (raw ws)++-- | Process a 'Ast.Paragraph' and deal with sequence of 'Ast.Reply'.+paragraph :: (Monoid a, GenConf c a)+          => Ast.Paragraph a+          -> Generator c a ()+paragraph l@(h:r) = do+  temp <- askConf paragraphTemplate+  between <- askConf betweenDialogue++  apply temp (recGen between False (willBeDialogue l) l)++  where+    isDialogue (Ast.Dialogue _ _) = True+    isDialogue _ = False++    willBeDialogue (h:n:r) = isDialogue n+    willBeDialogue _ = False++    recGen :: (Monoid a, GenConf c a)+           => a+           -> Bool+           -> Bool+           -> [Ast.Component a]+           -> Generator c a ()+    recGen between p n (c:rst) = do+      case (p, isDialogue c) of (True, True) -> do raw between+                                                   reset+                                _ -> return ()+      component p n c+      recGen between (isDialogue c) (willBeDialogue rst) rst+    recGen _ _ _ [] = return ()++-- | Process a sequence of 'Ast.Paragraph'.+paragraphs :: (Monoid a, GenConf c a)+           => [Ast.Paragraph a]+           -> Generator c a ()+paragraphs (h:r) = do paragraph h+                      reset+                      paragraphs r+paragraphs [] = return ()++-- | Process a 'Ast.Section'.+section :: (Monoid a, GenConf c a)+        => Ast.Section a+        -> Generator c a ()+section (Ast.Story ps) = do temp <- askConf storyTemplate++                            apply temp (paragraphs ps)+section (Ast.Aside cls ps) = do temp <- askConf asideTemplate+                                apply (temp cls) (paragraphs ps)++section (Ast.Failing f) = do+    temp <- askConf errorTemplate+    temp2 <- askConf storyTemplate+    apply (temp2 . temp) (raw f)++-- | Process a sequence of 'Ast.Section'.+sections :: (Monoid a, GenConf c a)+         => [Ast.Section a]+         -> Generator c a ()+sections (s:r) = do section s+                    sections r+sections [] = return ()++-- | Process a 'Ast.Document', that is a complete Ogmarkup document.+document :: (Monoid a, GenConf c a)+          => Ast.Document a+         -> Generator c a ()+document d = do temp <- askConf documentTemplate++                apply temp (sections d)
+ src/Text/Ogmarkup/Private/Parser.hs view
@@ -0,0 +1,376 @@+{-|+Module      : Text.Ogmarkup.Private.Parser+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++This module provides several parsers that can be used in order to+extract the 'Ast' of an Ogmarkup document.++Please consider that only 'document' should be used outside this+module.+-}++{-# LANGUAGE OverloadedStrings #-}++module Text.Ogmarkup.Private.Parser where++import           Control.Monad+import           Data.String+import Text.ParserCombinators.Parsec hiding (parse)++import qualified Text.Ogmarkup.Private.Ast     as Ast++-- | Keep track of the currently opened formats.+data ParserState = ParserState { -- | Already parsing text with emphasis+                                 parseWithEmph        :: Bool+                                 -- | Already parsing text with strong+                                 --   emphasis+                               , parseWithStrongEmph  :: Bool+                                 -- | Already parsing a quote+                               , parseWithinQuote     :: Bool+                               }++-- | Update the 'ParserState' to guard against nested emphasis.+enterEmph :: OgmarkupParser ()+enterEmph = do st <- getState+               if parseWithEmph st+                 then fail "guard against nested emphasis"+                 else do setState st { parseWithEmph = True }+                         return ()++-- | Update the 'ParserState' to be able to parse input with emphasis+-- again.+leaveEmph :: OgmarkupParser ()+leaveEmph = do st <- getState+               if parseWithEmph st+                 then do setState st { parseWithEmph = False }+                         return ()+                 else fail "cannot leave emphasis when you did not enter"++-- | Update the 'ParserState' to guard against nested strong emphasis.+enterStrongEmph :: OgmarkupParser ()+enterStrongEmph = do st <- getState+                     if parseWithStrongEmph st+                       then fail "guard against nested strong emphasis"+                       else do setState st { parseWithStrongEmph = True }+                               return ()++-- | Update the 'ParserState' to be able to parse input with strong emphasis+-- again.+leaveStrongEmph :: OgmarkupParser ()+leaveStrongEmph = do st <- getState+                     if parseWithStrongEmph st+                       then do setState st { parseWithStrongEmph = False }+                               return ()+                       else fail "cannot leave strong emphasis when you did not enter"++-- | Update the 'ParserState' to guard against nested quoted inputs.+enterQuote :: OgmarkupParser ()+enterQuote = do st <- getState+                if parseWithinQuote st+                  then fail "guard against nested quotes"+                  else do setState st { parseWithinQuote = True }+                          return ()++-- | Update the 'ParserState' to be able to parse an input+-- surrounded by quotes again.+leaveQuote :: OgmarkupParser ()+leaveQuote = do st <- getState+                if parseWithinQuote st+                  then do setState st { parseWithinQuote = False }+                          return ()+                  else fail "cannot leave quote when you did not enter"++-- | A initial ParserState instance to be used at the begining of+-- a document parsing.+initParserState :: ParserState+initParserState = ParserState False False False++-- | An ogmarkup parser processes 'Char' tokens and carries a 'ParserState'.+type OgmarkupParser = GenParser Char ParserState++-- | A wrapper around the 'runParser' function of Parsec. It uses+-- 'initParserState' as an initial state.+parse :: OgmarkupParser a -> String -> String -> Either ParseError a+parse ogma = runParser ogma initParserState++-- | Try its best to parse an ogmarkup document. When it encounters an+--   error, it returns an Ast and the remaining input.+--+--   See 'Ast.Document'.+document :: IsString a+         => OgmarkupParser (Ast.Document a, String)+document = do spaces+              sects <- many (try section)+              input <- getInput++              return (sects, input)++-- | See 'Ast.Section'.+section :: IsString a+           => OgmarkupParser (Ast.Section a)+section = aside <|> story++-- | See 'Ast.Aside'.+aside :: IsString a+         => OgmarkupParser (Ast.Section a)+aside = do asideSeparator+           cls <- optionMaybe asideClass+           spaces+           ps <- many1 (paragraph <* spaces)+           asideSeparator+           manyTill space (skip (char '\n') <|> eof)+           spaces++           return $ Ast.Aside cls ps+  where+    asideClass :: IsString a+               => OgmarkupParser a+    asideClass = do a <- many1 letter+                    asideSeparator++                    return $ fromString a++-- | See 'Ast.Story'.+story :: IsString a+      => OgmarkupParser (Ast.Section a)+story = Ast.Story `fmap` many1 (paragraph <* spaces)++-- | See 'Ast.Paragraph'.+paragraph :: IsString a+          => OgmarkupParser (Ast.Paragraph a)+paragraph = many1 component <* blank++-- | See 'Ast.Component'.+component :: IsString a+          => OgmarkupParser (Ast.Component a)+component = try (dialogue <|> thought <|> teller) <|> illformed++-- | See 'Ast.IllFormed'.+illformed :: IsString a+          => OgmarkupParser (Ast.Component a)+illformed = Ast.IllFormed `fmap` restOfParagraph++-- | Parse the rest of the current paragraph with no regards for the+-- ogmarkup syntax. This Parser is used when the document is ill-formed, to+-- find a new point of synchronization.+restOfParagraph :: IsString a+                => OgmarkupParser a+restOfParagraph = do lookAhead anyToken+                     notFollowedBy endOfParagraph+                     str <- manyTill anyToken (lookAhead $ try endOfParagraph)+                     return $ fromString str++-- | See 'Ast.Teller'.+teller :: IsString a+       => OgmarkupParser (Ast.Component a)+teller = Ast.Teller `fmap` many1 format++-- | See 'Ast.Dialogue'.+dialogue :: IsString a+         => OgmarkupParser (Ast.Component a)+dialogue = talk '[' ']' Ast.Dialogue++-- | See 'Ast.Thought'.+thought :: IsString a+        => OgmarkupParser (Ast.Component a)+thought = talk '<' '>' Ast.Thought++-- | @'talk' c c' constr@ wraps a reply surrounded by @c@ and @c'@ inside+--   @constr@ (either 'Ast.Dialogue' or 'Ast.Thought').+talk :: IsString a+     => Char -- ^ A character to mark the begining of a reply+     -> Char -- ^ A character to mark the end of a reply+     -> (Ast.Reply a -> Maybe a -> Ast.Component a) -- ^ Either 'Ast.Dialogue' or 'Ast.Thought' according to the situation+     -> OgmarkupParser (Ast.Component a)+talk c c' constructor = do+  rep <- reply c c'+  auth <- optionMaybe characterName+  blank++  return $ constructor rep auth++-- | Parse the name of the character which speaks or thinks. According to+-- the ogmarkup syntax, it is surrounded by parentheses.+characterName :: IsString a+           => OgmarkupParser a+characterName = do+  char '('+  notFollowedBy (char ')') <?> "Empty character names are not allowed"+  auth <- manyTill anyToken (char ')') <?> "Missing closing )"++  return $ fromString auth++-- | 'reply' parses a 'Ast.Reply'.+reply :: IsString a+      => Char+      -> Char+      -> OgmarkupParser (Ast.Reply a)+reply c c' = do char c+                blank+                p1 <- many1 format+                x <- oneOf ['|', c']++                case x of '|' -> do blank+                                    ws <- many1 format+                                    char '|' <?> "Missing | to close the with say"+                                    blank+                                    p2 <- many format+                                    char c'++                                    return $ Ast.WithSay p1 ws p2+                          _ -> return $ Ast.Simple p1++-- | See 'Ast.Format'.+format :: IsString a+       => OgmarkupParser (Ast.Format a)+format = choice [ raw+                , emph+                , strongEmph+                , quote+                ]++-- | See 'Ast.Raw'.+raw :: IsString a+    => OgmarkupParser (Ast.Format a)+raw = Ast.Raw `fmap` many1 atom ++-- | See 'Ast.Emph'.+emph :: IsString a+     => OgmarkupParser (Ast.Format a)+emph = do char '*'+          blank+          enterEmph+          f <- format+          fs <- manyTill format (char '*' >> blank)+          leaveEmph+          return . Ast.Emph $ (f:fs)++-- | See 'Ast.StrongEmph'.+strongEmph :: IsString a+           => OgmarkupParser (Ast.Format a)+strongEmph = do char '+'+                blank+                enterStrongEmph+                f <- format+                fs <- manyTill format (char '+' >> blank)+                leaveStrongEmph+                return . Ast.StrongEmph $ (f:fs)++-- | See 'Ast.Quote'.+quote :: IsString a+      => OgmarkupParser (Ast.Format a)+quote = do char '"'+           blank+           enterQuote+           f <- format+           fs <- manyTill format (char '"' >> blank)+           leaveQuote+           return . Ast.Quote $ (f:fs)++-- | See 'Ast.Atom'.+atom :: IsString a+     => OgmarkupParser (Ast.Atom a)+atom = (mark <|> longword <|> word) <* blank++-- | See 'Ast.Word'. This parser does not consume the following spaces, so+--   the caller needs to take care of it.+word :: IsString a+     => OgmarkupParser (Ast.Atom a)+word = do lookAhead anyToken -- not the end of the parser+          notFollowedBy endOfWord++          str <- manyTill anyToken (lookAhead $ try endOfWord)++          return $ Ast.Word (fromString str)+  where+    specChar = "\"«»`+*[]<>|_\'’"++    endOfWord :: OgmarkupParser ()+    endOfWord =     eof <|> skip space <|> skip (oneOf specChar) <|> skip mark++-- | Wrap a raw string surrounded by @`@ inside a 'Ast.Word'.+--+--   >>> parse longword "" "`test *ei*`"+--   Right (Ast.Word "test *ei*")+--+--   Therefore, @`@ can be used to insert normally reserved symbol+--   inside a generated document.+longword :: IsString a+         => OgmarkupParser (Ast.Atom a)+longword = do char '`'+              notFollowedBy (char '`') <?> "empty raw string are not accepted"+              str <- manyTill anyToken (char '`')+              return $ Ast.Word (fromString str)++-- | See 'Ast.Punctuation'. Be aware that 'mark' does not parse the quotes+--   because they are processed 'quote'.+mark :: OgmarkupParser (Ast.Atom a)+mark = Ast.Punctuation `fmap` (semicolon+        <|> colon+        <|> question+        <|> exclamation+        <|> try longDash+        <|> try dash+        <|> hyphen+        <|> comma+        <|> apostrophe+        <|> try suspensionPoints+        <|> point)+  where+    parseMark p m = p >> return m++    semicolon        = parseMark (char ';') Ast.Semicolon+    colon            = parseMark (char ':') Ast.Colon+    question         = parseMark (char '?') Ast.Question+    exclamation      = parseMark (char '!') Ast.Exclamation+    longDash         = parseMark (string "—" <|> string "---") Ast.LongDash+    dash             = parseMark (string "–" <|> string "--") Ast.Dash+    hyphen           = parseMark (char '-') Ast.Hyphen+    comma            = parseMark (char ',') Ast.Comma+    point            = parseMark (char '.') Ast.Point+    apostrophe       = parseMark (char '\'' <|> char '’') Ast.Apostrophe+    suspensionPoints = parseMark (string ".." >> many (char '.')) Ast.SuspensionPoints++-- | See 'Ast.OpenQuote'. This parser consumes the following blank (see 'blank')+--   and skip the result.+openQuote :: OgmarkupParser ()+openQuote = do char '«' <|> char '"'+               blank++-- | See 'Ast.CloseQuote'. This parser consumes the following blank (see 'blank')+--   and skip the result.+closeQuote :: OgmarkupParser ()+closeQuote = do char '»' <|> char '"'+                blank++-- | An aside section (see 'Ast.Aside') is a particular region+--   surrounded by two lines of underscores (at least three).+--   This parser consumes one such line.+asideSeparator :: OgmarkupParser ()+asideSeparator = do string "__"+                    many1 (char '_')++                    return ()++-- | The end of a paragraph is the end of the document or two blank lines+-- or an aside separator, that is a line of underscores.+endOfParagraph :: OgmarkupParser ()+endOfParagraph = try betweenTwoSections+                 <|> asideSeparator+                 <|> eof+  where+    betweenTwoSections :: OgmarkupParser ()+    betweenTwoSections = do count 2 $ manyTill space (eof <|> skip (char '\n'))+                            spaces++-- | This parser consumes all the white spaces until it finds either an aside+--   surrounding marker (see 'Ast.Aside'), the end of the document or+--   one blank line. The latter marks the end of the current paragraph.+blank :: OgmarkupParser ()+blank = optional (notFollowedBy endOfParagraph >> spaces)++-- | @skip p@ parses @p@ and skips the result.+skip :: OgmarkupParser a -> OgmarkupParser ()+skip = void
+ src/Text/Ogmarkup/Private/Typography.hs view
@@ -0,0 +1,129 @@+{-|+Module      : Text.Ogmarkup.Private.Typography+Copyright   : (c) Ogma Project, 2016+License     : MIT+Stability   : experimental++This module provides the 'Typography' datatype along with two default instances+for French and English.+-}++{-# LANGUAGE OverloadedStrings #-}++module Text.Ogmarkup.Private.Typography where++import           Data.String+import qualified Text.Ogmarkup.Private.Ast as Ast++-- * Inner spaces representation++-- | Deal with typographic spaces, especially when it comes to+--   separating two texts. Because Space derives Ord, it is possible+--   to use min and max to determine which one to use in case of+--   a conflict.+data Space =+  Normal -- ^ A normal space that can be turned into a newline for displaying.+  | Nbsp -- ^ A non breakable space, it cannot be turned into a newline.+  | None -- ^ No space at all.+    deriving (Eq,Ord)++-- * Typography definition++-- | 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.+  }++-- | 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++-- | 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 _ = Normal++-- | From a Typography, it gives the space to privilege after the+--   input Text.+afterAtom :: Typography a+          -> Ast.Atom a+          -> Space+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.Word w) = w++-- * Ready-to-use Typography++-- | 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+  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, "…")++    prevT True = Just Ast.LongDash+    prevT False = Just Ast.OpenQuote++    nextT True = Nothing+    nextT False = Just Ast.CloseQuote++-- | 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)+  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, "…")
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}