Implemented more features

[Rakka.git] / Rakka / Wiki / Engine.hs

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 4cb150fa74b458b3a9431aa2248154123f239039..65009751dde7694c12a52fd4b678f5e5d20261ea 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -8,12 +8,15 @@ import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowTree
 import           Data.Encoding
 import           Data.Encoding.UTF8
+import qualified Data.Map as M
 import           Network.HTTP.Lucu
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.SystemConfig
+import           Rakka.Wiki
 import           Rakka.Wiki.Parser
 import           Rakka.Wiki.Formatter
+import           Rakka.Wiki.Interpreter
 import           Text.ParserCombinators.Parsec
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.DOM.TypeDefs
@@ -26,23 +29,85 @@ formatPage env
     = proc page
     -> do tree <- case pageType page of
                     MIMEType "text" "x-rakka" _
-                        -> formatWikiPage env -< page
+                        -> do let source = decodeLazy UTF8 (pageContent page)
+                              formatWikiPage env -< (Just page, source)
           attachXHtmlNs -< tree
 
 
 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                   Environment
-               -> a Page XmlTree
+               -> a (Maybe Page, String) XmlTree
 formatWikiPage env
-    = proc page
-    -> do let source = decodeLazy UTF8 (pageContent page)
-          case parse wikiPage "" source of
+    = proc (page, source)
+    -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
+          interpTable     <- getInterpTableA env -< ()
+
+          let parser = wikiPage (tableToFunc interpTable)
+
+          case parse parser "" source of
             Left  err
                 -> formatParseError -< err
 
             Right blocks
-                -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
-                      formatWikiBlocks -< (baseURI, blocks)
+                -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
+                      formatWikiBlocks -< (baseURI, xs)
+    where
+      tableToFunc :: InterpTable -> String -> Maybe CommandType
+      tableToFunc table name
+          = fmap commandType (M.lookup name table)
+
+
+interpretCommandsA :: ArrowIO a =>
+                      Environment
+                   -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
+interpretCommandsA = arrIO3 . interpretCommands
+
+
+interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
+interpretCommands _   _     _    []     = return []
+interpretCommands env table page blocks = mapM interpBlock blocks
+    where
+      interpBlock :: BlockElement -> IO BlockElement
+      interpBlock (List           list) = interpList list >>= return . List
+      interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
+      interpBlock (Preformatted   xs  ) = mapM interpInline xs >>= return . Preformatted
+      interpBlock (Paragraph      xs  ) = mapM interpInline xs >>= return . Paragraph
+      interpBlock others                = return others
+
+      interpList :: ListElement -> IO ListElement
+      interpList list = do items <- mapM interpListItem (listItems list)
+                           return $ list { listItems = items }
+
+      interpListItem :: ListItem -> IO ListItem
+      interpListItem []                  = return []
+      interpListItem ((Left  nested):xs) = do x  <- interpList nested >>= return . Left
+                                              xs <- interpListItem xs
+                                              return (x:xs)
+      interpListItem ((Right inline):xs) = do x  <- interpInline inline >>= return . Right
+                                              xs <- interpListItem xs
+                                              return (x:xs)
+
+      interpDefinition :: Definition -> IO Definition
+      interpDefinition def = do term <- mapM interpInline (defTerm def)
+                                desc <- mapM interpInline (defDesc def)
+                                return $ def { defTerm = term, defDesc = desc }
+
+      interpInline :: InlineElement -> IO InlineElement
+      interpInline (Italic    xs ) = mapM interpInline xs >>= return . Italic
+      interpInline (Bold      xs ) = mapM interpInline xs >>= return . Bold
+      interpInline (InlineCmd cmd) = interpInlineCmd cmd
+      interpInline others          = return others
+
+      interpInlineCmd :: InlineCommand -> IO InlineElement
+      interpInlineCmd cmd
+          = case M.lookup (iCmdName cmd) table of
+              Nothing
+                  -> fail ("no such interpreter: " ++ iCmdName cmd)
+
+              Just interp
+                  -> iciInterpret interp cmd page (envStorage env) (envSysConf env)
+                     >>=
+                     interpInline
 
 
 formatParseError :: ArrowXml a => a ParseError XmlTree