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
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)
runGenerator :: Monoid a
=> Generator c a x
-> c
-> a
runGenerator gen conf = fst $ runReader (execStateT (getState gen) (mempty, Nothing)) conf
askConf :: (c -> b)
-> Generator c a b
askConf f = f <$> ask
apply :: Monoid a
=> Template a
-> Generator c a x
-> Generator c a ()
apply app gen = do
(str, maybe) <- get
put (mempty, maybe)
gen
(str', maybe') <- get
put (str `mappend` app str', maybe')
reset :: Generator c a ()
reset = do
(str, _) <- get
put (str, Nothing)
raw :: Monoid a
=> a
-> Generator c a ()
raw str' = do
(str, maybePrev) <- get
put (str `mappend` str', maybePrev)
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)
maybeAtom :: (Monoid a, GenConf c a)
=> Maybe (Ast.Atom a)
-> Generator c a ()
maybeAtom (Just text) = atom text
maybeAtom Nothing = return ()
atoms :: (Monoid a, GenConf c a)
=> [Ast.Atom a]
-> Generator c a ()
atoms (f:rst) = do
atom f
atoms rst
atoms [] = return ()
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
formats :: (Monoid a, GenConf c a)
=> [Ast.Format a]
-> Generator c a ()
formats (f:rst) = do
format f
formats rst
formats [] = return ()
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
component :: (Monoid a, GenConf c a)
=> Bool
-> Bool
-> Ast.Component a
-> 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)
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 ()
paragraphs :: (Monoid a, GenConf c a)
=> [Ast.Paragraph a]
-> Generator c a ()
paragraphs (h:r) = do paragraph h
reset
paragraphs r
paragraphs [] = return ()
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)
sections :: (Monoid a, GenConf c a)
=> [Ast.Section a]
-> Generator c a ()
sections (s:r) = do section s
sections r
sections [] = return ()
document :: (Monoid a, GenConf c a)
=> Ast.Document a
-> Generator c a ()
document d = do temp <- askConf documentTemplate
apply temp (sections d)